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         break;
1132     case '+':
1133         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1134             paren = RX_LASTPAREN(rx);
1135             if (paren)
1136                 goto do_numbuf_fetch;
1137         }
1138         goto set_undef;
1139     case '\016':                /* ^N */
1140         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
1141             paren = RX_LASTCLOSEPAREN(rx);
1142             if (paren)
1143                 goto do_numbuf_fetch;
1144         }
1145         goto set_undef;
1146     case '.':
1147         if (GvIO(PL_last_in_gv)) {
1148             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
1149         }
1150         break;
1151     case '?':
1152         {
1153             sv_setiv(sv, (IV)STATUS_CURRENT);
1154 #ifdef COMPLEX_STATUS
1155             SvUPGRADE(sv, SVt_PVLV);
1156             LvTARGOFF(sv) = PL_statusvalue;
1157             LvTARGLEN(sv) = PL_statusvalue_vms;
1158 #endif
1159         }
1160         break;
1161     case '^':
1162         if (GvIOp(PL_defoutgv))
1163                 s = IoTOP_NAME(GvIOp(PL_defoutgv));
1164         if (s)
1165             sv_setpv(sv,s);
1166         else {
1167             sv_setpv(sv,GvENAME(PL_defoutgv));
1168             sv_catpvs(sv,"_TOP");
1169         }
1170         break;
1171     case '~':
1172         if (GvIOp(PL_defoutgv))
1173             s = IoFMT_NAME(GvIOp(PL_defoutgv));
1174         if (!s)
1175             s = GvENAME(PL_defoutgv);
1176         sv_setpv(sv,s);
1177         break;
1178     case '=':
1179         if (GvIO(PL_defoutgv))
1180             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1181         break;
1182     case '-':
1183         if (GvIO(PL_defoutgv))
1184             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1185         break;
1186     case '%':
1187         if (GvIO(PL_defoutgv))
1188             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1189         break;
1190     case ':':
1191     case '/':
1192         break;
1193     case '[':
1194         sv_setiv(sv, 0);
1195         break;
1196     case '|':
1197         if (GvIO(PL_defoutgv))
1198             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1199         break;
1200     case '\\':
1201         if (PL_ors_sv)
1202             sv_copypv(sv, PL_ors_sv);
1203         else
1204             goto set_undef;
1205         break;
1206     case '$': /* $$ */
1207         {
1208             IV const pid = (IV)PerlProc_getpid();
1209             if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
1210                 /* never set manually, or at least not since last fork */
1211                 sv_setiv(sv, pid);
1212                 /* never unsafe, even if reading in a tainted expression */
1213                 SvTAINTED_off(sv);
1214             }
1215             /* else a value has been assigned manually, so do nothing */
1216         }
1217         break;
1218     case '<':
1219         sv_setuid(sv, PerlProc_getuid());
1220         break;
1221     case '>':
1222         sv_setuid(sv, PerlProc_geteuid());
1223         break;
1224     case '(':
1225         sv_setgid(sv, PerlProc_getgid());
1226         goto add_groups;
1227     case ')':
1228         sv_setgid(sv, PerlProc_getegid());
1229       add_groups:
1230 #ifdef HAS_GETGROUPS
1231         {
1232             Groups_t *gary = NULL;
1233             I32 num_groups = getgroups(0, gary);
1234             if (num_groups > 0) {
1235                 I32 i;
1236                 Newx(gary, num_groups, Groups_t);
1237                 num_groups = getgroups(num_groups, gary);
1238                 for (i = 0; i < num_groups; i++)
1239                     Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]);
1240                 Safefree(gary);
1241             }
1242         }
1243         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1244 #endif
1245         break;
1246     case '0':
1247         break;
1248     }
1249     return 0;
1250
1251   set_undef:
1252     sv_set_undef(sv);
1253     return 0;
1254 }
1255
1256 int
1257 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1258 {
1259     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1260
1261     PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1262
1263     if (uf && uf->uf_val)
1264         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1265     return 0;
1266 }
1267
1268 int
1269 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1270 {
1271     STRLEN len = 0, klen;
1272     const char * const key = MgPV_const(mg,klen);
1273     const char *s = "";
1274
1275     PERL_ARGS_ASSERT_MAGIC_SETENV;
1276
1277     SvGETMAGIC(sv);
1278     if (SvOK(sv)) {
1279         /* defined environment variables are byte strings; unfortunately
1280            there is no SvPVbyte_force_nomg(), so we must do this piecewise */
1281         (void)SvPV_force_nomg_nolen(sv);
1282         sv_utf8_downgrade(sv, /* fail_ok */ TRUE);
1283         if (SvUTF8(sv)) {
1284             Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv");
1285             SvUTF8_off(sv);
1286         }
1287         s = SvPVX(sv);
1288         len = SvCUR(sv);
1289     }
1290     my_setenv(key, s); /* does the deed */
1291
1292 #ifdef DYNAMIC_ENV_FETCH
1293      /* We just undefd an environment var.  Is a replacement */
1294      /* waiting in the wings? */
1295     if (!len) {
1296         SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE);
1297         if (valp)
1298             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1299     }
1300 #endif
1301
1302 #if !defined(OS2) && !defined(WIN32) && !defined(MSDOS)
1303                             /* And you'll never guess what the dog had */
1304                             /*   in its mouth... */
1305     if (TAINTING_get) {
1306         MgTAINTEDDIR_off(mg);
1307 #ifdef VMS
1308         if (s && memEQs(key, klen, "DCL$PATH")) {
1309             char pathbuf[256], eltbuf[256], *cp, *elt;
1310             int i = 0, j = 0;
1311
1312             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1313             elt = eltbuf;
1314             do {          /* DCL$PATH may be a search list */
1315                 while (1) {   /* as may dev portion of any element */
1316                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1317                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1318                              cando_by_name(S_IWUSR,0,elt) ) {
1319                             MgTAINTEDDIR_on(mg);
1320                             return 0;
1321                         }
1322                     }
1323                     if ((cp = strchr(elt, ':')) != NULL)
1324                         *cp = '\0';
1325                     if (my_trnlnm(elt, eltbuf, j++))
1326                         elt = eltbuf;
1327                     else
1328                         break;
1329                 }
1330                 j = 0;
1331             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1332         }
1333 #endif /* VMS */
1334         if (s && memEQs(key, klen, "PATH")) {
1335             const char * const strend = s + len;
1336
1337             /* set MGf_TAINTEDDIR if any component of the new path is
1338              * relative or world-writeable */
1339             while (s < strend) {
1340                 char tmpbuf[256];
1341                 Stat_t st;
1342                 I32 i;
1343 #ifdef __VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1344                 const char path_sep = PL_perllib_sep;
1345 #else
1346                 const char path_sep = ':';
1347 #endif
1348                 s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
1349                              s, strend, path_sep, &i);
1350                 s++;
1351                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1352 #ifdef __VMS
1353                       /* no colon thus no device name -- assume relative path */
1354                       || (PL_perllib_sep != ':' && !strchr(tmpbuf, ':'))
1355                       /* Using Unix separator, e.g. under bash, so act line Unix */
1356                       || (PL_perllib_sep == ':' && *tmpbuf != '/')
1357 #else
1358                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1359 #endif
1360                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1361                     MgTAINTEDDIR_on(mg);
1362                     return 0;
1363                 }
1364             }
1365         }
1366     }
1367 #endif /* neither OS2 nor WIN32 nor MSDOS */
1368
1369     return 0;
1370 }
1371
1372 int
1373 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1374 {
1375     PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1376     PERL_UNUSED_ARG(sv);
1377     my_setenv(MgPV_nolen_const(mg),NULL);
1378     return 0;
1379 }
1380
1381 int
1382 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1383 {
1384     PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1385     PERL_UNUSED_ARG(mg);
1386 #if defined(VMS)
1387     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1388 #else
1389     if (PL_localizing) {
1390         HE* entry;
1391         my_clearenv();
1392         hv_iterinit(MUTABLE_HV(sv));
1393         while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1394             I32 keylen;
1395             my_setenv(hv_iterkey(entry, &keylen),
1396                       SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1397         }
1398     }
1399 #endif
1400     return 0;
1401 }
1402
1403 int
1404 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1405 {
1406     PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1407     PERL_UNUSED_ARG(sv);
1408     PERL_UNUSED_ARG(mg);
1409 #if defined(VMS)
1410     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1411 #else
1412     my_clearenv();
1413 #endif
1414     return 0;
1415 }
1416
1417 #ifndef PERL_MICRO
1418 #ifdef HAS_SIGPROCMASK
1419 static void
1420 restore_sigmask(pTHX_ SV *save_sv)
1421 {
1422     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1423     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1424 }
1425 #endif
1426 int
1427 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1428 {
1429     /* Are we fetching a signal entry? */
1430     int i = (I16)mg->mg_private;
1431
1432     PERL_ARGS_ASSERT_MAGIC_GETSIG;
1433
1434     if (!i) {
1435         STRLEN siglen;
1436         const char * sig = MgPV_const(mg, siglen);
1437         mg->mg_private = i = whichsig_pvn(sig, siglen);
1438     }
1439
1440     if (i > 0) {
1441         if(PL_psig_ptr[i])
1442             sv_setsv(sv,PL_psig_ptr[i]);
1443         else {
1444             Sighandler_t sigstate = rsignal_state(i);
1445 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1446             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1447                 sigstate = SIG_IGN;
1448 #endif
1449 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1450             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1451                 sigstate = SIG_DFL;
1452 #endif
1453             /* cache state so we don't fetch it again */
1454             if(sigstate == (Sighandler_t) SIG_IGN)
1455                 sv_setpvs(sv,"IGNORE");
1456             else
1457                 sv_set_undef(sv);
1458             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1459             SvTEMP_off(sv);
1460         }
1461     }
1462     return 0;
1463 }
1464 int
1465 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1466 {
1467     PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1468
1469     magic_setsig(NULL, mg);
1470     return sv_unmagic(sv, mg->mg_type);
1471 }
1472
1473
1474 #ifdef PERL_USE_3ARG_SIGHANDLER
1475 Signal_t
1476 Perl_csighandler(int sig, Siginfo_t *sip, void *uap)
1477 {
1478     Perl_csighandler3(sig, sip, uap);
1479 }
1480 #else
1481 Signal_t
1482 Perl_csighandler(int sig)
1483 {
1484     Perl_csighandler3(sig, NULL, NULL);
1485 }
1486 #endif
1487
1488 Signal_t
1489 Perl_csighandler1(int sig)
1490 {
1491     Perl_csighandler3(sig, NULL, NULL);
1492 }
1493
1494 /* Handler intended to directly handle signal calls from the kernel.
1495  * (Depending on configuration, the kernel may actually call one of the
1496  * wrappers csighandler() or csighandler1() instead.)
1497  * It either queues up the signal or dispatches it immediately depending
1498  * on whether safe signals are enabled and whether the signal is capable
1499  * of being deferred (e.g. SEGV isn't).
1500  */
1501
1502 Signal_t
1503 Perl_csighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1504 {
1505 #ifdef PERL_GET_SIG_CONTEXT
1506     dTHXa(PERL_GET_SIG_CONTEXT);
1507 #else
1508     dTHX;
1509 #endif
1510
1511 #ifdef PERL_USE_3ARG_SIGHANDLER
1512 #if defined(__cplusplus) && defined(__GNUC__)
1513     /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
1514      * parameters would be warned about. */
1515     PERL_UNUSED_ARG(sip);
1516     PERL_UNUSED_ARG(uap);
1517 #endif
1518 #endif
1519
1520 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1521     (void) rsignal(sig, PL_csighandlerp);
1522     if (PL_sig_ignoring[sig]) return;
1523 #endif
1524 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1525     if (PL_sig_defaulting[sig])
1526 #ifdef KILL_BY_SIGPRC
1527             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1528 #else
1529             exit(1);
1530 #endif
1531 #endif
1532     if (
1533 #ifdef SIGILL
1534            sig == SIGILL ||
1535 #endif
1536 #ifdef SIGBUS
1537            sig == SIGBUS ||
1538 #endif
1539 #ifdef SIGSEGV
1540            sig == SIGSEGV ||
1541 #endif
1542            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1543         /* Call the perl level handler now--
1544          * with risk we may be in malloc() or being destructed etc. */
1545     {
1546         if (PL_sighandlerp == Perl_sighandler)
1547             /* default handler, so can call perly_sighandler() directly
1548              * rather than via Perl_sighandler, passing the extra
1549              * 'safe = false' arg
1550              */
1551             Perl_perly_sighandler(sig, NULL, NULL, 0 /* unsafe */);
1552         else
1553 #ifdef PERL_USE_3ARG_SIGHANDLER
1554             (*PL_sighandlerp)(sig, NULL, NULL);
1555 #else
1556             (*PL_sighandlerp)(sig);
1557 #endif
1558     }
1559     else {
1560         if (!PL_psig_pend) return;
1561         /* Set a flag to say this signal is pending, that is awaiting delivery after
1562          * the current Perl opcode completes */
1563         PL_psig_pend[sig]++;
1564
1565 #ifndef SIG_PENDING_DIE_COUNT
1566 #  define SIG_PENDING_DIE_COUNT 120
1567 #endif
1568         /* Add one to say _a_ signal is pending */
1569         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1570             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1571                        (unsigned long)SIG_PENDING_DIE_COUNT);
1572     }
1573 }
1574
1575 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1576 void
1577 Perl_csighandler_init(void)
1578 {
1579     int sig;
1580     if (PL_sig_handlers_initted) return;
1581
1582     for (sig = 1; sig < SIG_SIZE; sig++) {
1583 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1584         dTHX;
1585         PL_sig_defaulting[sig] = 1;
1586         (void) rsignal(sig, PL_csighandlerp);
1587 #endif
1588 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1589         PL_sig_ignoring[sig] = 0;
1590 #endif
1591     }
1592     PL_sig_handlers_initted = 1;
1593 }
1594 #endif
1595
1596 #if defined HAS_SIGPROCMASK
1597 static void
1598 unblock_sigmask(pTHX_ void* newset)
1599 {
1600     PERL_UNUSED_CONTEXT;
1601     sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
1602 }
1603 #endif
1604
1605 void
1606 Perl_despatch_signals(pTHX)
1607 {
1608     int sig;
1609     PL_sig_pending = 0;
1610     for (sig = 1; sig < SIG_SIZE; sig++) {
1611         if (PL_psig_pend[sig]) {
1612             dSAVE_ERRNO;
1613 #ifdef HAS_SIGPROCMASK
1614             /* From sigaction(2) (FreeBSD man page):
1615              * | Signal routines normally execute with the signal that
1616              * | caused their invocation blocked, but other signals may
1617              * | yet occur.
1618              * Emulation of this behavior (from within Perl) is enabled
1619              * using sigprocmask
1620              */
1621             int was_blocked;
1622             sigset_t newset, oldset;
1623
1624             sigemptyset(&newset);
1625             sigaddset(&newset, sig);
1626             sigprocmask(SIG_BLOCK, &newset, &oldset);
1627             was_blocked = sigismember(&oldset, sig);
1628             if (!was_blocked) {
1629                 SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t));
1630                 ENTER;
1631                 SAVEFREESV(save_sv);
1632                 SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv));
1633             }
1634 #endif
1635             PL_psig_pend[sig] = 0;
1636             if (PL_sighandlerp == Perl_sighandler)
1637                 /* default handler, so can call perly_sighandler() directly
1638                  * rather than via Perl_sighandler, passing the extra
1639                  * 'safe = true' arg
1640                  */
1641                 Perl_perly_sighandler(sig, NULL, NULL, 1 /* safe */);
1642             else
1643 #ifdef PERL_USE_3ARG_SIGHANDLER
1644                 (*PL_sighandlerp)(sig, NULL, NULL);
1645 #else
1646                 (*PL_sighandlerp)(sig);
1647 #endif
1648
1649 #ifdef HAS_SIGPROCMASK
1650             if (!was_blocked)
1651                 LEAVE;
1652 #endif
1653             RESTORE_ERRNO;
1654         }
1655     }
1656 }
1657
1658 /* sv of NULL signifies that we're acting as magic_clearsig.  */
1659 int
1660 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1661 {
1662     I32 i;
1663     SV** svp = NULL;
1664     /* Need to be careful with SvREFCNT_dec(), because that can have side
1665      * effects (due to closures). We must make sure that the new disposition
1666      * is in place before it is called.
1667      */
1668     SV* to_dec = NULL;
1669     STRLEN len;
1670 #ifdef HAS_SIGPROCMASK
1671     sigset_t set, save;
1672     SV* save_sv;
1673 #endif
1674     const char *s = MgPV_const(mg,len);
1675
1676     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1677
1678     if (*s == '_') {
1679         if (memEQs(s, len, "__DIE__"))
1680             svp = &PL_diehook;
1681         else if (memEQs(s, len, "__WARN__")
1682                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1683             /* Merge the existing behaviours, which are as follows:
1684                magic_setsig, we always set svp to &PL_warnhook
1685                (hence we always change the warnings handler)
1686                For magic_clearsig, we don't change the warnings handler if it's
1687                set to the &PL_warnhook.  */
1688             svp = &PL_warnhook;
1689         } else if (sv) {
1690             SV *tmp = sv_newmortal();
1691             Perl_croak(aTHX_ "No such hook: %s",
1692                                 pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1693         }
1694         i = 0;
1695         if (svp && *svp) {
1696             if (*svp != PERL_WARNHOOK_FATAL)
1697                 to_dec = *svp;
1698             *svp = NULL;
1699         }
1700     }
1701     else {
1702         i = (I16)mg->mg_private;
1703         if (!i) {
1704             i = whichsig_pvn(s, len);   /* ...no, a brick */
1705             mg->mg_private = (U16)i;
1706         }
1707         if (i <= 0) {
1708             if (sv) {
1709                 SV *tmp = sv_newmortal();
1710                 Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s",
1711                                             pv_pretty(tmp, s, len, 0, NULL, NULL, 0));
1712             }
1713             return 0;
1714         }
1715 #ifdef HAS_SIGPROCMASK
1716         /* Avoid having the signal arrive at a bad time, if possible. */
1717         sigemptyset(&set);
1718         sigaddset(&set,i);
1719         sigprocmask(SIG_BLOCK, &set, &save);
1720         ENTER;
1721         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1722         SAVEFREESV(save_sv);
1723         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1724 #endif
1725         PERL_ASYNC_CHECK();
1726 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1727         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1728 #endif
1729 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1730         PL_sig_ignoring[i] = 0;
1731 #endif
1732 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1733         PL_sig_defaulting[i] = 0;
1734 #endif
1735         to_dec = PL_psig_ptr[i];
1736         if (sv) {
1737             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1738             SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1739
1740             /* Signals don't change name during the program's execution, so once
1741                they're cached in the appropriate slot of PL_psig_name, they can
1742                stay there.
1743
1744                Ideally we'd find some way of making SVs at (C) compile time, or
1745                at least, doing most of the work.  */
1746             if (!PL_psig_name[i]) {
1747                 const char* name = PL_sig_name[i];
1748                 PL_psig_name[i] = newSVpvn(name, strlen(name));
1749                 SvREADONLY_on(PL_psig_name[i]);
1750             }
1751         } else {
1752             SvREFCNT_dec(PL_psig_name[i]);
1753             PL_psig_name[i] = NULL;
1754             PL_psig_ptr[i] = NULL;
1755         }
1756     }
1757     if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1758         if (i) {
1759             (void)rsignal(i, PL_csighandlerp);
1760         }
1761         else
1762             *svp = SvREFCNT_inc_simple_NN(sv);
1763     } else {
1764         if (sv && SvOK(sv)) {
1765             s = SvPV_force(sv, len);
1766         } else {
1767             sv = NULL;
1768         }
1769         if (sv && memEQs(s, len,"IGNORE")) {
1770             if (i) {
1771 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1772                 PL_sig_ignoring[i] = 1;
1773                 (void)rsignal(i, PL_csighandlerp);
1774 #else
1775                 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1776 #endif
1777             }
1778         }
1779         else if (!sv || memEQs(s, len,"DEFAULT") || !len) {
1780             if (i) {
1781 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1782                 PL_sig_defaulting[i] = 1;
1783                 (void)rsignal(i, PL_csighandlerp);
1784 #else
1785                 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1786 #endif
1787             }
1788         }
1789         else {
1790             /*
1791              * We should warn if HINT_STRICT_REFS, but without
1792              * access to a known hint bit in a known OP, we can't
1793              * tell whether HINT_STRICT_REFS is in force or not.
1794              */
1795             if (!memchr(s, ':', len) && !memchr(s, '\'', len))
1796                 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1797                                      SV_GMAGIC);
1798             if (i)
1799                 (void)rsignal(i, PL_csighandlerp);
1800             else
1801                 *svp = SvREFCNT_inc_simple_NN(sv);
1802         }
1803     }
1804
1805 #ifdef HAS_SIGPROCMASK
1806     if(i)
1807         LEAVE;
1808 #endif
1809     SvREFCNT_dec(to_dec);
1810     return 0;
1811 }
1812 #endif /* !PERL_MICRO */
1813
1814 int
1815 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1816 {
1817     PERL_ARGS_ASSERT_MAGIC_SETISA;
1818     PERL_UNUSED_ARG(sv);
1819
1820     /* Skip _isaelem because _isa will handle it shortly */
1821     if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem)
1822         return 0;
1823
1824     return magic_clearisa(NULL, mg);
1825 }
1826
1827 /* sv of NULL signifies that we're acting as magic_setisa.  */
1828 int
1829 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1830 {
1831     HV* stash;
1832     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1833
1834     /* Bail out if destruction is going on */
1835     if(PL_phase == PERL_PHASE_DESTRUCT) return 0;
1836
1837     if (sv)
1838         av_clear(MUTABLE_AV(sv));
1839
1840     if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj))
1841         /* This occurs with setisa_elem magic, which calls this
1842            same function. */
1843         mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
1844
1845     assert(mg);
1846     if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
1847         SV **svp = AvARRAY((AV *)mg->mg_obj);
1848         I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
1849         while (items--) {
1850             stash = GvSTASH((GV *)*svp++);
1851             if (stash && HvENAME(stash)) mro_isa_changed_in(stash);
1852         }
1853
1854         return 0;
1855     }
1856
1857     stash = GvSTASH(
1858         (const GV *)mg->mg_obj
1859     );
1860
1861     /* The stash may have been detached from the symbol table, so check its
1862        name before doing anything. */
1863     if (stash && HvENAME_get(stash))
1864         mro_isa_changed_in(stash);
1865
1866     return 0;
1867 }
1868
1869 int
1870 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1871 {
1872     HV * const hv = MUTABLE_HV(LvTARG(sv));
1873     I32 i = 0;
1874
1875     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1876     PERL_UNUSED_ARG(mg);
1877
1878     if (hv) {
1879          (void) hv_iterinit(hv);
1880          if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
1881              i = HvUSEDKEYS(hv);
1882          else {
1883              while (hv_iternext(hv))
1884                  i++;
1885          }
1886     }
1887
1888     sv_setiv(sv, (IV)i);
1889     return 0;
1890 }
1891
1892 int
1893 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1894 {
1895     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1896     PERL_UNUSED_ARG(mg);
1897     if (LvTARG(sv)) {
1898         hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
1899     }
1900     return 0;
1901 }
1902
1903 /*
1904 =for apidoc_section $magic
1905 =for apidoc magic_methcall
1906
1907 Invoke a magic method (like FETCH).
1908
1909 C<sv> and C<mg> are the tied thingy and the tie magic.
1910
1911 C<meth> is the name of the method to call.
1912
1913 C<argc> is the number of args (in addition to $self) to pass to the method.
1914
1915 The C<flags> can be:
1916
1917     G_DISCARD     invoke method with G_DISCARD flag and don't
1918                   return a value
1919     G_UNDEF_FILL  fill the stack with argc pointers to
1920                   PL_sv_undef
1921
1922 The arguments themselves are any values following the C<flags> argument.
1923
1924 Returns the SV (if any) returned by the method, or C<NULL> on failure.
1925
1926
1927 =cut
1928 */
1929
1930 SV*
1931 Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1932                     U32 argc, ...)
1933 {
1934     dSP;
1935     SV* ret = NULL;
1936
1937     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1938
1939     ENTER;
1940
1941     if (flags & G_WRITING_TO_STDERR) {
1942         SAVETMPS;
1943
1944         save_re_context();
1945         SAVESPTR(PL_stderrgv);
1946         PL_stderrgv = NULL;
1947     }
1948
1949     PUSHSTACKi(PERLSI_MAGIC);
1950     PUSHMARK(SP);
1951
1952     /* EXTEND() expects a signed argc; don't wrap when casting */
1953     assert(argc <= I32_MAX);
1954     EXTEND(SP, (I32)argc+1);
1955     PUSHs(SvTIED_obj(sv, mg));
1956     if (flags & G_UNDEF_FILL) {
1957         while (argc--) {
1958             PUSHs(&PL_sv_undef);
1959         }
1960     } else if (argc > 0) {
1961         va_list args;
1962         va_start(args, argc);
1963
1964         do {
1965             SV *const this_sv = va_arg(args, SV *);
1966             PUSHs(this_sv);
1967         } while (--argc);
1968
1969         va_end(args);
1970     }
1971     PUTBACK;
1972     if (flags & G_DISCARD) {
1973         call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED);
1974     }
1975     else {
1976         if (call_sv(meth, G_SCALAR|G_METHOD_NAMED))
1977             ret = *PL_stack_sp--;
1978     }
1979     POPSTACK;
1980     if (flags & G_WRITING_TO_STDERR)
1981         FREETMPS;
1982     LEAVE;
1983     return ret;
1984 }
1985
1986 /* wrapper for magic_methcall that creates the first arg */
1987
1988 STATIC SV*
1989 S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
1990     int n, SV *val)
1991 {
1992     SV* arg1 = NULL;
1993
1994     PERL_ARGS_ASSERT_MAGIC_METHCALL1;
1995
1996     if (mg->mg_ptr) {
1997         if (mg->mg_len >= 0) {
1998             arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
1999         }
2000         else if (mg->mg_len == HEf_SVKEY)
2001             arg1 = MUTABLE_SV(mg->mg_ptr);
2002     }
2003     else if (mg->mg_type == PERL_MAGIC_tiedelem) {
2004         arg1 = newSViv((IV)(mg->mg_len));
2005         sv_2mortal(arg1);
2006     }
2007     if (!arg1) {
2008         return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val);
2009     }
2010     return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val);
2011 }
2012
2013 STATIC int
2014 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
2015 {
2016     SV* ret;
2017
2018     PERL_ARGS_ASSERT_MAGIC_METHPACK;
2019
2020     ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
2021     if (ret)
2022         sv_setsv(sv, ret);
2023     return 0;
2024 }
2025
2026 int
2027 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
2028 {
2029     PERL_ARGS_ASSERT_MAGIC_GETPACK;
2030
2031     if (mg->mg_type == PERL_MAGIC_tiedelem)
2032         mg->mg_flags |= MGf_GSKIP;
2033     magic_methpack(sv,mg,SV_CONST(FETCH));
2034     return 0;
2035 }
2036
2037 int
2038 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
2039 {
2040     MAGIC *tmg;
2041     SV    *val;
2042
2043     PERL_ARGS_ASSERT_MAGIC_SETPACK;
2044
2045     /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
2046      * STORE() is not $val, but rather a PVLV (the sv in this call), whose
2047      * public flags indicate its value based on copying from $val. Doing
2048      * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
2049      * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
2050      * wrong if $val happened to be tainted, as sv hasn't got magic
2051      * enabled, even though taint magic is in the chain. In which case,
2052      * fake up a temporary tainted value (this is easier than temporarily
2053      * re-enabling magic on sv). */
2054
2055     if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint))
2056         && (tmg->mg_len & 1))
2057     {
2058         val = sv_mortalcopy(sv);
2059         SvTAINTED_on(val);
2060     }
2061     else
2062         val = sv;
2063
2064     magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val);
2065     return 0;
2066 }
2067
2068 int
2069 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
2070 {
2071     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
2072
2073     if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0;
2074     return magic_methpack(sv,mg,SV_CONST(DELETE));
2075 }
2076
2077
2078 U32
2079 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
2080 {
2081     I32 retval = 0;
2082     SV* retsv;
2083
2084     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
2085
2086     retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL);
2087     if (retsv) {
2088         retval = SvIV(retsv)-1;
2089         if (retval < -1)
2090             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
2091     }
2092     return (U32) retval;
2093 }
2094
2095 int
2096 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
2097 {
2098     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
2099
2100     Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
2101     return 0;
2102 }
2103
2104 int
2105 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
2106 {
2107     SV* ret;
2108
2109     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
2110
2111     ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key)
2112         : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0);
2113     if (ret)
2114         sv_setsv(key,ret);
2115     return 0;
2116 }
2117
2118 int
2119 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
2120 {
2121     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
2122
2123     return magic_methpack(sv,mg,SV_CONST(EXISTS));
2124 }
2125
2126 SV *
2127 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
2128 {
2129     SV *retval;
2130     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
2131     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
2132
2133     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
2134
2135     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
2136         SV *key;
2137         if (HvEITER_get(hv))
2138             /* we are in an iteration so the hash cannot be empty */
2139             return &PL_sv_yes;
2140         /* no xhv_eiter so now use FIRSTKEY */
2141         key = sv_newmortal();
2142         magic_nextpack(MUTABLE_SV(hv), mg, key);
2143         HvEITER_set(hv, NULL);     /* need to reset iterator */
2144         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
2145     }
2146
2147     /* there is a SCALAR method that we can call */
2148     retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0);
2149     if (!retval)
2150         retval = &PL_sv_undef;
2151     return retval;
2152 }
2153
2154 int
2155 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
2156 {
2157     SV **svp;
2158
2159     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
2160
2161     /* The magic ptr/len for the debugger's hash should always be an SV.  */
2162     if (UNLIKELY(mg->mg_len != HEf_SVKEY)) {
2163         Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'",
2164                    (IV)mg->mg_len, mg->mg_ptr);
2165     }
2166
2167     /* Use sv_2iv instead of SvIV() as the former generates smaller code, and
2168        setting/clearing debugger breakpoints is not a hot path.  */
2169     svp = av_fetch(MUTABLE_AV(mg->mg_obj),
2170                    sv_2iv(MUTABLE_SV((mg)->mg_ptr)), FALSE);
2171
2172     if (svp && SvIOKp(*svp)) {
2173         OP * const o = INT2PTR(OP*,SvIVX(*svp));
2174         if (o) {
2175 #ifdef PERL_DEBUG_READONLY_OPS
2176             Slab_to_rw(OpSLAB(o));
2177 #endif
2178             /* set or clear breakpoint in the relevant control op */
2179             if (SvTRUE(sv))
2180                 o->op_flags |= OPf_SPECIAL;
2181             else
2182                 o->op_flags &= ~OPf_SPECIAL;
2183 #ifdef PERL_DEBUG_READONLY_OPS
2184             Slab_to_ro(OpSLAB(o));
2185 #endif
2186         }
2187     }
2188     return 0;
2189 }
2190
2191 int
2192 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
2193 {
2194     AV * const obj = MUTABLE_AV(mg->mg_obj);
2195
2196     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
2197
2198     if (obj) {
2199         sv_setiv(sv, AvFILL(obj));
2200     } else {
2201         sv_set_undef(sv);
2202     }
2203     return 0;
2204 }
2205
2206 int
2207 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
2208 {
2209     AV * const obj = MUTABLE_AV(mg->mg_obj);
2210
2211     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
2212
2213     if (obj) {
2214         av_fill(obj, SvIV(sv));
2215     } else {
2216         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2217                        "Attempt to set length of freed array");
2218     }
2219     return 0;
2220 }
2221
2222 int
2223 Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
2224 {
2225     PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
2226     PERL_UNUSED_ARG(sv);
2227     PERL_UNUSED_CONTEXT;
2228
2229     /* Reset the iterator when the array is cleared */
2230     if (sizeof(IV) == sizeof(SSize_t)) {
2231         *((IV *) &(mg->mg_len)) = 0;
2232     } else {
2233         if (mg->mg_ptr)
2234             *((IV *) mg->mg_ptr) = 0;
2235     }
2236
2237     return 0;
2238 }
2239
2240 int
2241 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
2242 {
2243     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
2244     PERL_UNUSED_ARG(sv);
2245
2246     /* during global destruction, mg_obj may already have been freed */
2247     if (PL_in_clean_all)
2248         return 0;
2249
2250     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
2251
2252     if (mg) {
2253         /* arylen scalar holds a pointer back to the array, but doesn't own a
2254            reference. Hence the we (the array) are about to go away with it
2255            still pointing at us. Clear its pointer, else it would be pointing
2256            at free memory. See the comment in sv_magic about reference loops,
2257            and why it can't own a reference to us.  */
2258         mg->mg_obj = 0;
2259     }
2260     return 0;
2261 }
2262
2263 int
2264 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
2265 {
2266     SV* const lsv = LvTARG(sv);
2267     MAGIC * const found = mg_find_mglob(lsv);
2268
2269     PERL_ARGS_ASSERT_MAGIC_GETPOS;
2270     PERL_UNUSED_ARG(mg);
2271
2272     if (found && found->mg_len != -1) {
2273             STRLEN i = found->mg_len;
2274             if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
2275                 i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
2276             sv_setuv(sv, i);
2277             return 0;
2278     }
2279     sv_set_undef(sv);
2280     return 0;
2281 }
2282
2283 int
2284 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
2285 {
2286     SV* const lsv = LvTARG(sv);
2287     SSize_t pos;
2288     STRLEN len;
2289     MAGIC* found;
2290     const char *s;
2291
2292     PERL_ARGS_ASSERT_MAGIC_SETPOS;
2293     PERL_UNUSED_ARG(mg);
2294
2295     found = mg_find_mglob(lsv);
2296     if (!found) {
2297         if (!SvOK(sv))
2298             return 0;
2299         found = sv_magicext_mglob(lsv);
2300     }
2301     else if (!SvOK(sv)) {
2302         found->mg_len = -1;
2303         return 0;
2304     }
2305     s = SvPV_const(lsv, len);
2306
2307     pos = SvIV(sv);
2308
2309     if (DO_UTF8(lsv)) {
2310         const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
2311         if (ulen)
2312             len = ulen;
2313     }
2314
2315     if (pos < 0) {
2316         pos += len;
2317         if (pos < 0)
2318             pos = 0;
2319     }
2320     else if (pos > (SSize_t)len)
2321         pos = len;
2322
2323     found->mg_len = pos;
2324     found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
2325
2326     return 0;
2327 }
2328
2329 int
2330 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2331 {
2332     STRLEN len;
2333     SV * const lsv = LvTARG(sv);
2334     const char * const tmps = SvPV_const(lsv,len);
2335     STRLEN offs = LvTARGOFF(sv);
2336     STRLEN rem = LvTARGLEN(sv);
2337     const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2338     const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
2339
2340     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2341     PERL_UNUSED_ARG(mg);
2342
2343     if (!translate_substr_offsets(
2344             SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len,
2345             negoff ? -(IV)offs : (IV)offs, !negoff,
2346             negrem ? -(IV)rem  : (IV)rem,  !negrem, &offs, &rem
2347     )) {
2348         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
2349         sv_set_undef(sv);
2350         return 0;
2351     }
2352
2353     if (SvUTF8(lsv))
2354         offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
2355     sv_setpvn(sv, tmps + offs, rem);
2356     if (SvUTF8(lsv))
2357         SvUTF8_on(sv);
2358     return 0;
2359 }
2360
2361 int
2362 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2363 {
2364     STRLEN len, lsv_len, oldtarglen, newtarglen;
2365     const char * const tmps = SvPV_const(sv, len);
2366     SV * const lsv = LvTARG(sv);
2367     STRLEN lvoff = LvTARGOFF(sv);
2368     STRLEN lvlen = LvTARGLEN(sv);
2369     const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
2370     const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
2371
2372     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2373     PERL_UNUSED_ARG(mg);
2374
2375     SvGETMAGIC(lsv);
2376     if (SvROK(lsv))
2377         Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
2378                             "Attempt to use reference as lvalue in substr"
2379         );
2380     SvPV_force_nomg(lsv,lsv_len);
2381     if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv);
2382     if (!translate_substr_offsets(
2383             lsv_len,
2384             negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
2385             neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
2386     ))
2387         Perl_croak(aTHX_ "substr outside of string");
2388     oldtarglen = lvlen;
2389     if (DO_UTF8(sv)) {
2390         sv_utf8_upgrade_nomg(lsv);
2391         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2392         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2393         newtarglen = sv_or_pv_len_utf8(sv, tmps, len);
2394         SvUTF8_on(lsv);
2395     }
2396     else if (SvUTF8(lsv)) {
2397         const char *utf8;
2398         lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
2399         newtarglen = len;
2400         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2401         sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
2402         Safefree(utf8);
2403     }
2404     else {
2405         sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
2406         newtarglen = len;
2407     }
2408     if (!neglen) LvTARGLEN(sv) = newtarglen;
2409     if (negoff)  LvTARGOFF(sv) += newtarglen - oldtarglen;
2410
2411     return 0;
2412 }
2413
2414 int
2415 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2416 {
2417     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2418     PERL_UNUSED_ARG(sv);
2419 #ifdef NO_TAINT_SUPPORT
2420     PERL_UNUSED_ARG(mg);
2421 #endif
2422
2423     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
2424     return 0;
2425 }
2426
2427 int
2428 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2429 {
2430     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2431     PERL_UNUSED_ARG(sv);
2432
2433     /* update taint status */
2434     if (TAINT_get)
2435         mg->mg_len |= 1;
2436     else
2437         mg->mg_len &= ~1;
2438     return 0;
2439 }
2440
2441 int
2442 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2443 {
2444     SV * const lsv = LvTARG(sv);
2445     char errflags = LvFLAGS(sv);
2446
2447     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2448     PERL_UNUSED_ARG(mg);
2449
2450     /* non-zero errflags implies deferred out-of-range condition */
2451     assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
2452     sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2453
2454     return 0;
2455 }
2456
2457 int
2458 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2459 {
2460     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2461     PERL_UNUSED_ARG(mg);
2462     do_vecset(sv);      /* XXX slurp this routine */
2463     return 0;
2464 }
2465
2466 SV *
2467 Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
2468 {
2469     SV *targ = NULL;
2470     PERL_ARGS_ASSERT_DEFELEM_TARGET;
2471     if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
2472     assert(mg);
2473     if (LvTARGLEN(sv)) {
2474         if (mg->mg_obj) {
2475             SV * const ahv = LvTARG(sv);
2476             HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
2477             if (he)
2478                 targ = HeVAL(he);
2479         }
2480         else if (LvSTARGOFF(sv) >= 0) {
2481             AV *const av = MUTABLE_AV(LvTARG(sv));
2482             if (LvSTARGOFF(sv) <= AvFILL(av))
2483             {
2484               if (SvRMAGICAL(av)) {
2485                 SV * const * const svp = av_fetch(av, LvSTARGOFF(sv), 0);
2486                 targ = svp ? *svp : NULL;
2487               }
2488               else
2489                 targ = AvARRAY(av)[LvSTARGOFF(sv)];
2490             }
2491         }
2492         if (targ && (targ != &PL_sv_undef)) {
2493             /* somebody else defined it for us */
2494             SvREFCNT_dec(LvTARG(sv));
2495             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2496             LvTARGLEN(sv) = 0;
2497             SvREFCNT_dec(mg->mg_obj);
2498             mg->mg_obj = NULL;
2499             mg->mg_flags &= ~MGf_REFCOUNTED;
2500         }
2501         return targ;
2502     }
2503     else
2504         return LvTARG(sv);
2505 }
2506
2507 int
2508 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2509 {
2510     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2511
2512     sv_setsv(sv, defelem_target(sv, mg));
2513     return 0;
2514 }
2515
2516 int
2517 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2518 {
2519     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2520     PERL_UNUSED_ARG(mg);
2521     if (LvTARGLEN(sv))
2522         vivify_defelem(sv);
2523     if (LvTARG(sv)) {
2524         sv_setsv(LvTARG(sv), sv);
2525         SvSETMAGIC(LvTARG(sv));
2526     }
2527     return 0;
2528 }
2529
2530 void
2531 Perl_vivify_defelem(pTHX_ SV *sv)
2532 {
2533     MAGIC *mg;
2534     SV *value = NULL;
2535
2536     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2537
2538     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2539         return;
2540     if (mg->mg_obj) {
2541         SV * const ahv = LvTARG(sv);
2542         HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
2543         if (he)
2544             value = HeVAL(he);
2545         if (!value || value == &PL_sv_undef)
2546             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2547     }
2548     else if (LvSTARGOFF(sv) < 0)
2549         Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2550     else {
2551         AV *const av = MUTABLE_AV(LvTARG(sv));
2552         if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av))
2553             LvTARG(sv) = NULL;  /* array can't be extended */
2554         else {
2555             SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE);
2556             if (!svp || !(value = *svp))
2557                 Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv));
2558         }
2559     }
2560     SvREFCNT_inc_simple_void(value);
2561     SvREFCNT_dec(LvTARG(sv));
2562     LvTARG(sv) = value;
2563     LvTARGLEN(sv) = 0;
2564     SvREFCNT_dec(mg->mg_obj);
2565     mg->mg_obj = NULL;
2566     mg->mg_flags &= ~MGf_REFCOUNTED;
2567 }
2568
2569 int
2570 Perl_magic_setnonelem(pTHX_ SV *sv, MAGIC *mg)
2571 {
2572     PERL_ARGS_ASSERT_MAGIC_SETNONELEM;
2573     PERL_UNUSED_ARG(mg);
2574     sv_unmagic(sv, PERL_MAGIC_nonelem);
2575     return 0;
2576 }
2577
2578 int
2579 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2580 {
2581     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2582     Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
2583     return 0;
2584 }
2585
2586 int
2587 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2588 {
2589     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2590     PERL_UNUSED_CONTEXT;
2591     PERL_UNUSED_ARG(sv);
2592     mg->mg_len = -1;
2593     return 0;
2594 }
2595
2596
2597 int
2598 Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg)
2599 {
2600     PERL_ARGS_ASSERT_MAGIC_FREEMGLOB;
2601     PERL_UNUSED_ARG(sv);
2602
2603     /* glob magic uses mg_len as a string length rather than a buffer
2604      * length, so we need to free even with mg_len == 0: hence we can't
2605      * rely on standard magic free handling */
2606     assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1);
2607     Safefree(mg->mg_ptr);
2608     mg->mg_ptr = NULL;
2609     return 0;
2610 }
2611
2612
2613 int
2614 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2615 {
2616     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2617
2618     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2619
2620     if (uf && uf->uf_set)
2621         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2622     return 0;
2623 }
2624
2625 int
2626 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2627 {
2628     const char type = mg->mg_type;
2629
2630     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2631
2632     assert(    type == PERL_MAGIC_fm
2633             || type == PERL_MAGIC_qr
2634             || type == PERL_MAGIC_bm);
2635     return sv_unmagic(sv, type);
2636 }
2637
2638 #ifdef USE_LOCALE_COLLATE
2639 int
2640 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2641 {
2642     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2643
2644     /*
2645      * RenE<eacute> Descartes said "I think not."
2646      * and vanished with a faint plop.
2647      */
2648     PERL_UNUSED_CONTEXT;
2649     PERL_UNUSED_ARG(sv);
2650     if (mg->mg_ptr) {
2651         Safefree(mg->mg_ptr);
2652         mg->mg_ptr = NULL;
2653         mg->mg_len = -1;
2654     }
2655     return 0;
2656 }
2657
2658 int
2659 Perl_magic_freecollxfrm(pTHX_ SV *sv, MAGIC *mg)
2660 {
2661     PERL_ARGS_ASSERT_MAGIC_FREECOLLXFRM;
2662     PERL_UNUSED_ARG(sv);
2663
2664     /* Collate magic uses mg_len as a string length rather than a buffer
2665      * length, so we need to free even with mg_len == 0: hence we can't
2666      * rely on standard magic free handling */
2667     if (mg->mg_len >= 0) {
2668         assert(mg->mg_type == PERL_MAGIC_collxfrm);
2669         Safefree(mg->mg_ptr);
2670         mg->mg_ptr = NULL;
2671     }
2672
2673     return 0;
2674 }
2675 #endif /* USE_LOCALE_COLLATE */
2676
2677 /* Just clear the UTF-8 cache data. */
2678 int
2679 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2680 {
2681     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2682     PERL_UNUSED_CONTEXT;
2683     PERL_UNUSED_ARG(sv);
2684     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2685     mg->mg_ptr = NULL;
2686     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2687     return 0;
2688 }
2689
2690 int
2691 Perl_magic_freeutf8(pTHX_ SV *sv, MAGIC *mg)
2692 {
2693     PERL_ARGS_ASSERT_MAGIC_FREEUTF8;
2694     PERL_UNUSED_ARG(sv);
2695
2696     /* utf8 magic uses mg_len as a string length rather than a buffer
2697      * length, so we need to free even with mg_len == 0: hence we can't
2698      * rely on standard magic free handling */
2699     assert(mg->mg_type == PERL_MAGIC_utf8 && mg->mg_len >= -1);
2700     Safefree(mg->mg_ptr);
2701     mg->mg_ptr = NULL;
2702     return 0;
2703 }
2704
2705
2706 int
2707 Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
2708 {
2709     const char *bad = NULL;
2710     PERL_ARGS_ASSERT_MAGIC_SETLVREF;
2711     if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
2712     switch (mg->mg_private & OPpLVREF_TYPE) {
2713     case OPpLVREF_SV:
2714         if (SvTYPE(SvRV(sv)) > SVt_PVLV)
2715             bad = " SCALAR";
2716         break;
2717     case OPpLVREF_AV:
2718         if (SvTYPE(SvRV(sv)) != SVt_PVAV)
2719             bad = "n ARRAY";
2720         break;
2721     case OPpLVREF_HV:
2722         if (SvTYPE(SvRV(sv)) != SVt_PVHV)
2723             bad = " HASH";
2724         break;
2725     case OPpLVREF_CV:
2726         if (SvTYPE(SvRV(sv)) != SVt_PVCV)
2727             bad = " CODE";
2728     }
2729     if (bad)
2730         /* diag_listed_as: Assigned value is not %s reference */
2731         Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
2732     switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
2733     case 0:
2734     {
2735         SV * const old = PAD_SV(mg->mg_len);
2736         PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
2737         SvREFCNT_dec(old);
2738         break;
2739     }
2740     case SVt_PVGV:
2741         gv_setref(mg->mg_obj, sv);
2742         SvSETMAGIC(mg->mg_obj);
2743         break;
2744     case SVt_PVAV:
2745         av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
2746                  SvREFCNT_inc_simple_NN(SvRV(sv)));
2747         break;
2748     case SVt_PVHV:
2749         (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
2750                            SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
2751     }
2752     if (mg->mg_flags & MGf_PERSIST)
2753         NOOP; /* This sv is in use as an iterator var and will be reused,
2754                  so we must leave the magic.  */
2755     else
2756         /* This sv could be returned by the assignment op, so clear the
2757            magic, as lvrefs are an implementation detail that must not be
2758            leaked to the user.  */
2759         sv_unmagic(sv, PERL_MAGIC_lvref);
2760     return 0;
2761 }
2762
2763 static void
2764 S_set_dollarzero(pTHX_ SV *sv)
2765     PERL_TSA_REQUIRES(PL_dollarzero_mutex)
2766 {
2767     const char *s;
2768     STRLEN len;
2769 #ifdef HAS_SETPROCTITLE
2770     /* The BSDs don't show the argv[] in ps(1) output, they
2771      * show a string from the process struct and provide
2772      * the setproctitle() routine to manipulate that. */
2773     if (PL_origalen != 1) {
2774         s = SvPV_const(sv, len);
2775 #   if __FreeBSD_version > 410001 || defined(__DragonFly__)
2776         /* The leading "-" removes the "perl: " prefix,
2777          * but not the "(perl) suffix from the ps(1)
2778          * output, because that's what ps(1) shows if the
2779          * argv[] is modified. */
2780         setproctitle("-%s", s);
2781 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2782         /* This doesn't really work if you assume that
2783          * $0 = 'foobar'; will wipe out 'perl' from the $0
2784          * because in ps(1) output the result will be like
2785          * sprintf("perl: %s (perl)", s)
2786          * I guess this is a security feature:
2787          * one (a user process) cannot get rid of the original name.
2788          * --jhi */
2789         setproctitle("%s", s);
2790 #   endif
2791     }
2792 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2793     if (PL_origalen != 1) {
2794         union pstun un;
2795         s = SvPV_const(sv, len);
2796         un.pst_command = (char *)s;
2797         pstat(PSTAT_SETCMD, un, len, 0, 0);
2798     }
2799 #else
2800     if (PL_origalen > 1) {
2801         I32 i;
2802         /* PL_origalen is set in perl_parse(). */
2803         s = SvPV_force(sv,len);
2804         if (len >= (STRLEN)PL_origalen-1) {
2805             /* Longer than original, will be truncated. We assume that
2806              * PL_origalen bytes are available. */
2807             Copy(s, PL_origargv[0], PL_origalen-1, char);
2808         }
2809         else {
2810             /* Shorter than original, will be padded. */
2811 #ifdef PERL_DARWIN
2812             /* Special case for Mac OS X: see [perl #38868] */
2813             const int pad = 0;
2814 #else
2815             /* Is the space counterintuitive?  Yes.
2816              * (You were expecting \0?)
2817              * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2818              * --jhi */
2819             const int pad = ' ';
2820 #endif
2821             Copy(s, PL_origargv[0], len, char);
2822             PL_origargv[0][len] = 0;
2823             memset(PL_origargv[0] + len + 1,
2824                    pad,  PL_origalen - len - 1);
2825         }
2826         PL_origargv[0][PL_origalen-1] = 0;
2827         for (i = 1; i < PL_origargc; i++)
2828             PL_origargv[i] = 0;
2829 #ifdef HAS_PRCTL_SET_NAME
2830         /* Set the legacy process name in addition to the POSIX name on Linux */
2831         if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
2832             /* diag_listed_as: SKIPME */
2833             Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
2834         }
2835 #endif
2836     }
2837 #endif
2838 }
2839
2840 int
2841 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2842 {
2843     I32 paren;
2844     const REGEXP * rx;
2845     I32 i;
2846     STRLEN len;
2847     MAGIC *tmg;
2848
2849     PERL_ARGS_ASSERT_MAGIC_SET;
2850
2851     if (!mg->mg_ptr) {
2852         paren = mg->mg_len;
2853         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2854           setparen_got_rx:
2855             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2856         } else {
2857             /* Croak with a READONLY error when a numbered match var is
2858              * set without a previous pattern match. Unless it's C<local $1>
2859              */
2860           croakparen:
2861             if (!PL_localizing) {
2862                 Perl_croak_no_modify();
2863             }
2864         }
2865         return 0;
2866     }
2867
2868     switch (*mg->mg_ptr) {
2869     case '\001':        /* ^A */
2870         if (SvOK(sv)) sv_copypv(PL_bodytarget, sv);
2871         else SvOK_off(PL_bodytarget);
2872         FmLINES(PL_bodytarget) = 0;
2873         if (SvPOK(PL_bodytarget)) {
2874             char *s = SvPVX(PL_bodytarget);
2875             char *e = SvEND(PL_bodytarget);
2876             while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
2877                 FmLINES(PL_bodytarget)++;
2878                 s++;
2879             }
2880         }
2881         /* mg_set() has temporarily made sv non-magical */
2882         if (TAINTING_get) {
2883             if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1)
2884                 SvTAINTED_on(PL_bodytarget);
2885             else
2886                 SvTAINTED_off(PL_bodytarget);
2887         }
2888         break;
2889     case '\003':        /* ^C */
2890         PL_minus_c = cBOOL(SvIV(sv));
2891         break;
2892
2893     case '\004':        /* ^D */
2894 #ifdef DEBUGGING
2895         {
2896             const char *s = SvPV_nolen_const(sv);
2897             PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2898             if (DEBUG_x_TEST || DEBUG_B_TEST)
2899                 dump_all_perl(!DEBUG_B_TEST);
2900         }
2901 #else
2902         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2903 #endif
2904         break;
2905     case '\005':  /* ^E */
2906         if (*(mg->mg_ptr+1) == '\0') {
2907 #ifdef VMS
2908             set_vaxc_errno(SvIV(sv));
2909 #elif defined(WIN32)
2910             SetLastError( SvIV(sv) );
2911 #elif defined(OS2)
2912             os2_setsyserrno(SvIV(sv));
2913 #else
2914             /* will anyone ever use this? */
2915             SETERRNO(SvIV(sv), 4);
2916 #endif
2917         }
2918         else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
2919             Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
2920         break;
2921     case '\006':        /* ^F */
2922         if (mg->mg_ptr[1] == '\0') {
2923             PL_maxsysfd = SvIV(sv);
2924         }
2925         break;
2926     case '\010':        /* ^H */
2927         {
2928             U32 save_hints = PL_hints;
2929             PL_hints = SvUV(sv);
2930
2931             /* If wasn't UTF-8, and now is, notify the parser */
2932             if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
2933                 notify_parser_that_changed_to_utf8();
2934             }
2935         }
2936         break;
2937     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2938         Safefree(PL_inplace);
2939         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2940         break;
2941     case '\016':        /* ^N */
2942         if (PL_curpm && (rx = PM_GETRE(PL_curpm))
2943          && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
2944         goto croakparen;
2945     case '\017':        /* ^O */
2946         if (*(mg->mg_ptr+1) == '\0') {
2947             Safefree(PL_osname);
2948             PL_osname = NULL;
2949             if (SvOK(sv)) {
2950                 TAINT_PROPER("assigning to $^O");
2951                 PL_osname = savesvpv(sv);
2952             }
2953         }
2954         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2955             STRLEN len;
2956             const char *const start = SvPV(sv, len);
2957             const char *out = (const char*)memchr(start, '\0', len);
2958             SV *tmp;
2959
2960
2961             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2962             PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2963
2964             /* Opening for input is more common than opening for output, so
2965                ensure that hints for input are sooner on linked list.  */
2966             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2967                                        SvUTF8(sv))
2968                 : newSVpvs_flags("", SvUTF8(sv));
2969             (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
2970             mg_set(tmp);
2971
2972             tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
2973                                         SvUTF8(sv));
2974             (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
2975             mg_set(tmp);
2976         }
2977         break;
2978     case '\020':        /* ^P */
2979           PL_perldb = SvIV(sv);
2980           if (PL_perldb && !PL_DBsingle)
2981               init_debugger();
2982       break;
2983     case '\024':        /* ^T */
2984 #ifdef BIG_TIME
2985         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2986 #else
2987         PL_basetime = (Time_t)SvIV(sv);
2988 #endif
2989         break;
2990     case '\025':        /* ^UTF8CACHE */
2991          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2992              PL_utf8cache = (signed char) sv_2iv(sv);
2993          }
2994          break;
2995     case '\027':        /* ^W & $^WARNING_BITS */
2996         if (*(mg->mg_ptr+1) == '\0') {
2997             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2998                 i = SvIV(sv);
2999                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
3000                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
3001             }
3002         }
3003         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
3004             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
3005                 if (!SvPOK(sv)) {
3006             free_and_set_cop_warnings(&PL_compiling, pWARN_STD);
3007                     break;
3008                 }
3009                 {
3010                     STRLEN len, i;
3011                     int not_none = 0, not_all = 0;
3012                     const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
3013                     for (i = 0 ; i < len ; ++i) {
3014                         not_none |= ptr[i];
3015                         not_all |= ptr[i] ^ 0x55;
3016                     }
3017                     if (!not_none) {
3018                 free_and_set_cop_warnings(&PL_compiling, pWARN_NONE);
3019                     } else if (len >= WARNsize && !not_all) {
3020                 free_and_set_cop_warnings(&PL_compiling, pWARN_ALL);
3021                     PL_dowarn |= G_WARN_ONCE ;
3022                 }
3023             else {
3024                              STRLEN len;
3025                              const char *const p = SvPV_const(sv, len);
3026
3027                              PL_compiling.cop_warnings
3028                                  = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
3029                                                          p, len);
3030
3031                      if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
3032                             PL_dowarn |= G_WARN_ONCE ;
3033                }
3034
3035                 }
3036             }
3037         }
3038         break;
3039     case '.':
3040         if (PL_localizing) {
3041             if (PL_localizing == 1)
3042                 SAVESPTR(PL_last_in_gv);
3043         }
3044         else if (SvOK(sv) && GvIO(PL_last_in_gv))
3045             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
3046         break;
3047     case '^':
3048         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
3049         IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3050         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3051         break;
3052     case '~':
3053         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
3054         IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
3055         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
3056         break;
3057     case '=':
3058         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
3059         break;
3060     case '-':
3061         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
3062         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
3063                 IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
3064         break;
3065     case '%':
3066         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
3067         break;
3068     case '|':
3069         {
3070             IO * const io = GvIO(PL_defoutgv);
3071             if(!io)
3072               break;
3073             if ((SvIV(sv)) == 0)
3074                 IoFLAGS(io) &= ~IOf_FLUSH;
3075             else {
3076                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
3077                     PerlIO *ofp = IoOFP(io);
3078                     if (ofp)
3079                         (void)PerlIO_flush(ofp);
3080                     IoFLAGS(io) |= IOf_FLUSH;
3081                 }
3082             }
3083         }
3084         break;
3085     case '/':
3086         {
3087             if (SvROK(sv)) {
3088                 SV *referent = SvRV(sv);
3089                 const char *reftype = sv_reftype(referent, 0);
3090                 /* XXX: dodgy type check: This leaves me feeling dirty, but
3091                  * the alternative is to copy pretty much the entire
3092                  * sv_reftype() into this routine, or to do a full string
3093                  * comparison on the return of sv_reftype() both of which
3094                  * make me feel worse! NOTE, do not modify this comment
3095                  * without reviewing the corresponding comment in
3096                  * sv_reftype(). - Yves */
3097                 if (reftype[0] == 'S' || reftype[0] == 'L') {
3098                     IV val = SvIV(referent);
3099                     if (val <= 0) {
3100                         sv_setsv(sv, PL_rs);
3101                         Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
3102                                          val < 0 ? "a negative integer" : "zero");
3103                     }
3104                 } else {
3105                     sv_setsv(sv, PL_rs);
3106                     /* diag_listed_as: Setting $/ to %s reference is forbidden */
3107                     Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
3108                                       *reftype == 'A' ? "n" : "", reftype);
3109                 }
3110             }
3111             SvREFCNT_dec(PL_rs);
3112             PL_rs = newSVsv(sv);
3113         }
3114         break;
3115     case '\\':
3116         SvREFCNT_dec(PL_ors_sv);
3117         if (SvOK(sv)) {
3118             PL_ors_sv = newSVsv(sv);
3119         }
3120         else {
3121             PL_ors_sv = NULL;
3122         }
3123         break;
3124     case '[':
3125         if (SvIV(sv) != 0)
3126             Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
3127         break;
3128     case '?':
3129 #ifdef COMPLEX_STATUS
3130         if (PL_localizing == 2) {
3131             SvUPGRADE(sv, SVt_PVLV);
3132             PL_statusvalue = LvTARGOFF(sv);
3133             PL_statusvalue_vms = LvTARGLEN(sv);
3134         }
3135         else
3136 #endif
3137 #ifdef VMSISH_STATUS
3138         if (VMSISH_STATUS)
3139             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
3140         else
3141 #endif
3142             STATUS_UNIX_EXIT_SET(SvIV(sv));
3143         break;
3144     case '!':
3145         {
3146 #ifdef VMS
3147 #   define PERL_VMS_BANG vaxc$errno
3148 #else
3149 #   define PERL_VMS_BANG 0
3150 #endif
3151 #if defined(WIN32)
3152         SETERRNO(win32_get_errno(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0),
3153                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3154 #else
3155         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
3156                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
3157 #endif
3158         }
3159         break;
3160     case '<':
3161         {
3162         /* XXX $< currently silently ignores failures */
3163         const Uid_t new_uid = SvUID(sv);
3164         PL_delaymagic_uid = new_uid;
3165         if (PL_delaymagic) {
3166             PL_delaymagic |= DM_RUID;
3167             break;                              /* don't do magic till later */
3168         }
3169 #ifdef HAS_SETRUID
3170         PERL_UNUSED_RESULT(setruid(new_uid));
3171 #elif defined(HAS_SETREUID)
3172         PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
3173 #elif defined(HAS_SETRESUID)
3174         PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
3175 #else
3176         if (new_uid == PerlProc_geteuid()) {            /* special case $< = $> */
3177 #  ifdef PERL_DARWIN
3178             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
3179             if (new_uid != 0 && PerlProc_getuid() == 0)
3180                 PERL_UNUSED_RESULT(PerlProc_setuid(0));
3181 #  endif
3182             PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
3183         } else {
3184             Perl_croak(aTHX_ "setruid() not implemented");
3185         }
3186 #endif
3187         break;
3188         }
3189     case '>':
3190         {
3191         /* XXX $> currently silently ignores failures */
3192         const Uid_t new_euid = SvUID(sv);
3193         PL_delaymagic_euid = new_euid;
3194         if (PL_delaymagic) {
3195             PL_delaymagic |= DM_EUID;
3196             break;                              /* don't do magic till later */
3197         }
3198 #ifdef HAS_SETEUID
3199         PERL_UNUSED_RESULT(seteuid(new_euid));
3200 #elif defined(HAS_SETREUID)
3201         PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
3202 #elif defined(HAS_SETRESUID)
3203         PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
3204 #else
3205         if (new_euid == PerlProc_getuid())              /* special case $> = $< */
3206             PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
3207         else {
3208             Perl_croak(aTHX_ "seteuid() not implemented");
3209         }
3210 #endif
3211         break;
3212         }
3213     case '(':
3214         {
3215         /* XXX $( currently silently ignores failures */
3216         const Gid_t new_gid = SvGID(sv);
3217         PL_delaymagic_gid = new_gid;
3218         if (PL_delaymagic) {
3219             PL_delaymagic |= DM_RGID;
3220             break;                              /* don't do magic till later */
3221         }
3222 #ifdef HAS_SETRGID
3223         PERL_UNUSED_RESULT(setrgid(new_gid));
3224 #elif defined(HAS_SETREGID)
3225         PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
3226 #elif defined(HAS_SETRESGID)
3227         PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
3228 #else
3229         if (new_gid == PerlProc_getegid())                      /* special case $( = $) */
3230             PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
3231         else {
3232             Perl_croak(aTHX_ "setrgid() not implemented");
3233         }
3234 #endif
3235         break;
3236         }
3237     case ')':
3238         {
3239 /* (hv) best guess: maybe we'll need configure probes to do a better job,
3240  * but you can override it if you need to.
3241  */
3242 #ifndef INVALID_GID
3243 #define INVALID_GID ((Gid_t)-1)
3244 #endif
3245         /* XXX $) currently silently ignores failures */
3246         Gid_t new_egid;
3247 #ifdef HAS_SETGROUPS
3248         {
3249             const char *p = SvPV_const(sv, len);
3250             Groups_t *gary = NULL;
3251             const char* p_end = p + len;
3252             const char* endptr = p_end;
3253             UV uv;
3254 #ifdef _SC_NGROUPS_MAX
3255            int maxgrp = sysconf(_SC_NGROUPS_MAX);
3256
3257            if (maxgrp < 0)
3258                maxgrp = NGROUPS;
3259 #else
3260            int maxgrp = NGROUPS;
3261 #endif
3262
3263             while (isSPACE(*p))
3264                 ++p;
3265             if (grok_atoUV(p, &uv, &endptr))
3266                 new_egid = (Gid_t)uv;
3267             else {
3268                 new_egid = INVALID_GID;
3269                 endptr = NULL;
3270             }
3271             for (i = 0; i < maxgrp; ++i) {
3272                 if (endptr == NULL)
3273                     break;
3274                 p = endptr;
3275                 endptr = p_end;
3276                 while (isSPACE(*p))
3277                     ++p;
3278                 if (!*p)
3279                     break;
3280                 if (!gary)
3281                     Newx(gary, i + 1, Groups_t);
3282                 else
3283                     Renew(gary, i + 1, Groups_t);
3284                 if (grok_atoUV(p, &uv, &endptr))
3285                     gary[i] = (Groups_t)uv;
3286                 else {
3287                     gary[i] = INVALID_GID;
3288                     endptr = NULL;
3289                 }
3290             }
3291             if (i)
3292                 PERL_UNUSED_RESULT(setgroups(i, gary));
3293             Safefree(gary);
3294         }
3295 #else  /* HAS_SETGROUPS */
3296         new_egid = SvGID(sv);
3297 #endif /* HAS_SETGROUPS */
3298         PL_delaymagic_egid = new_egid;
3299         if (PL_delaymagic) {
3300             PL_delaymagic |= DM_EGID;
3301             break;                              /* don't do magic till later */
3302         }
3303 #ifdef HAS_SETEGID
3304         PERL_UNUSED_RESULT(setegid(new_egid));
3305 #elif defined(HAS_SETREGID)
3306         PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
3307 #elif defined(HAS_SETRESGID)
3308         PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
3309 #else
3310         if (new_egid == PerlProc_getgid())                      /* special case $) = $( */
3311             PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
3312         else {
3313             Perl_croak(aTHX_ "setegid() not implemented");
3314         }
3315 #endif
3316         break;
3317         }
3318     case ':':
3319         PL_chopset = SvPV_force(sv,len);
3320         break;
3321     case '$': /* $$ */
3322         /* Store the pid in mg->mg_obj so we can tell when a fork has
3323            occurred.  mg->mg_obj points to *$ by default, so clear it. */
3324         if (isGV(mg->mg_obj)) {
3325             if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */
3326                 SvREFCNT_dec(mg->mg_obj);
3327             mg->mg_flags |= MGf_REFCOUNTED;
3328             mg->mg_obj = newSViv((IV)PerlProc_getpid());
3329         }
3330         else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid());
3331         break;
3332     case '0':
3333         LOCK_DOLLARZERO_MUTEX;
3334         S_set_dollarzero(aTHX_ sv);
3335         UNLOCK_DOLLARZERO_MUTEX;
3336         break;
3337     }
3338     return 0;
3339 }
3340
3341 /*
3342 =for apidoc_section $signals
3343 =for apidoc whichsig
3344 =for apidoc_item whichsig_pv
3345 =for apidoc_item whichsig_pvn
3346 =for apidoc_item whichsig_sv
3347
3348 These all convert a signal name into its corresponding signal number;
3349 returning -1 if no corresponding number was found.
3350
3351 They differ only in the source of the signal name:
3352
3353 C<whichsig_pv> takes the name from the C<NUL>-terminated string starting at
3354 C<sig>.
3355
3356 C<whichsig> is merely a different spelling, a synonym, of C<whichsig_pv>.
3357
3358 C<whichsig_pvn> takes the name from the string starting at C<sig>, with length
3359 C<len> bytes.
3360
3361 C<whichsig_sv> takes the name from the PV stored in the SV C<sigsv>.
3362
3363 =cut
3364 */
3365
3366 I32
3367 Perl_whichsig_sv(pTHX_ SV *sigsv)
3368 {
3369     const char *sigpv;
3370     STRLEN siglen;
3371     PERL_ARGS_ASSERT_WHICHSIG_SV;
3372     sigpv = SvPV_const(sigsv, siglen);
3373     return whichsig_pvn(sigpv, siglen);
3374 }
3375
3376 I32
3377 Perl_whichsig_pv(pTHX_ const char *sig)
3378 {
3379     PERL_ARGS_ASSERT_WHICHSIG_PV;
3380     return whichsig_pvn(sig, strlen(sig));
3381 }
3382
3383 I32
3384 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len)
3385 {
3386     char* const* sigv;
3387
3388     PERL_ARGS_ASSERT_WHICHSIG_PVN;
3389     PERL_UNUSED_CONTEXT;
3390
3391     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
3392         if (strlen(*sigv) == len && memEQ(sig,*sigv, len))
3393             return PL_sig_num[sigv - (char* const*)PL_sig_name];
3394 #ifdef SIGCLD
3395     if (memEQs(sig, len, "CHLD"))
3396         return SIGCLD;
3397 #endif
3398 #ifdef SIGCHLD
3399     if (memEQs(sig, len, "CLD"))
3400         return SIGCHLD;
3401 #endif
3402     return -1;
3403 }
3404
3405
3406 /* Perl_sighandler(), Perl_sighandler1(), Perl_sighandler3():
3407  * these three function are intended to be called by the OS as 'C' level
3408  * signal handler functions in the case where unsafe signals are being
3409  * used - i.e. they immediately invoke Perl_perly_sighandler() to call the
3410  * perl-level sighandler, rather than deferring.
3411  * In fact, the core itself will normally use Perl_csighandler as the
3412  * OS-level handler; that function will then decide whether to queue the
3413  * signal or call Perl_sighandler / Perl_perly_sighandler itself. So these
3414  * functions are more useful for e.g. POSIX.xs when it wants explicit
3415  * control of what's happening.
3416  */
3417
3418
3419 #ifdef PERL_USE_3ARG_SIGHANDLER
3420
3421 Signal_t
3422 Perl_sighandler(int sig, Siginfo_t *sip, void *uap)
3423 {
3424     Perl_perly_sighandler(sig, sip, uap, 0);
3425 }
3426
3427 #else
3428
3429 Signal_t
3430 Perl_sighandler(int sig)
3431 {
3432     Perl_perly_sighandler(sig, NULL, NULL, 0);
3433 }
3434
3435 #endif
3436
3437 Signal_t
3438 Perl_sighandler1(int sig)
3439 {
3440     Perl_perly_sighandler(sig, NULL, NULL, 0);
3441 }
3442
3443 Signal_t
3444 Perl_sighandler3(int sig, Siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
3445 {
3446     Perl_perly_sighandler(sig, sip, uap, 0);
3447 }
3448
3449
3450 /* Invoke the perl-level signal handler. This function is called either
3451  * directly from one of the C-level signals handlers (Perl_sighandler or
3452  * Perl_csighandler), or for safe signals, later from
3453  * Perl_despatch_signals() at a suitable safe point during execution.
3454  *
3455  * 'safe' is a boolean indicating the latter call path.
3456  */
3457
3458 Signal_t
3459 Perl_perly_sighandler(int sig, Siginfo_t *sip PERL_UNUSED_DECL,
3460                     void *uap PERL_UNUSED_DECL, bool safe)
3461 {
3462 #ifdef PERL_GET_SIG_CONTEXT
3463     dTHXa(PERL_GET_SIG_CONTEXT);
3464 #else
3465     dTHX;
3466 #endif
3467     dSP;
3468     GV *gv = NULL;
3469     SV *sv = NULL;
3470     SV * const tSv = PL_Sv;
3471     CV *cv = NULL;
3472     OP *myop = PL_op;
3473     U32 flags = 0;
3474     XPV * const tXpv = PL_Xpv;
3475     I32 old_ss_ix = PL_savestack_ix;
3476     SV *errsv_save = NULL;
3477
3478
3479     if (!PL_psig_ptr[sig]) {
3480                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
3481                                  PL_sig_name[sig]);
3482                 exit(sig);
3483         }
3484
3485     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3486         /* Max number of items pushed there is 3*n or 4. We cannot fix
3487            infinity, so we fix 4 (in fact 5): */
3488         if (PL_savestack_ix + 15 <= PL_savestack_max) {
3489             flags |= 1;
3490             PL_savestack_ix += 5;               /* Protect save in progress. */
3491             SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL);
3492         }
3493     }
3494     /* sv_2cv is too complicated, try a simpler variant first: */
3495     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
3496         || SvTYPE(cv) != SVt_PVCV) {
3497         HV *st;
3498         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
3499     }
3500
3501     if (!cv || !CvROOT(cv)) {
3502         const HEK * const hek = gv
3503                         ? GvENAME_HEK(gv)
3504                         : cv && CvNAMED(cv)
3505                            ? CvNAME_HEK(cv)
3506                            : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
3507         if (hek)
3508             Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3509                                 "SIG%s handler \"%" HEKf "\" not defined.\n",
3510                                  PL_sig_name[sig], HEKfARG(hek));
3511              /* diag_listed_as: SIG%s handler "%s" not defined */
3512         else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
3513                            "SIG%s handler \"__ANON__\" not defined.\n",
3514                             PL_sig_name[sig]);
3515         goto cleanup;
3516     }
3517
3518     sv = PL_psig_name[sig]
3519             ? SvREFCNT_inc_NN(PL_psig_name[sig])
3520             : newSVpv(PL_sig_name[sig],0);
3521     flags |= 8;
3522     SAVEFREESV(sv);
3523
3524     if (PL_signals &  PERL_SIGNALS_UNSAFE_FLAG) {
3525         /* make sure our assumption about the size of the SAVEs are correct:
3526          * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */
3527         assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0)  == PL_savestack_ix);
3528     }
3529
3530     PUSHSTACKi(PERLSI_SIGNAL);
3531     PUSHMARK(SP);
3532     PUSHs(sv);
3533
3534 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
3535     {
3536          struct sigaction oact;
3537
3538          if (sip && sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
3539                HV *sih = newHV();
3540                SV *rv  = newRV_noinc(MUTABLE_SV(sih));
3541                /* The siginfo fields signo, code, errno, pid, uid,
3542                 * addr, status, and band are defined by POSIX/SUSv3. */
3543                (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
3544                (void)hv_stores(sih, "code", newSViv(sip->si_code));
3545 #  ifdef HAS_SIGINFO_SI_ERRNO
3546                (void)hv_stores(sih, "errno",      newSViv(sip->si_errno));
3547 #  endif
3548 #  ifdef HAS_SIGINFO_SI_STATUS
3549                (void)hv_stores(sih, "status",     newSViv(sip->si_status));
3550 #  endif
3551 #  ifdef HAS_SIGINFO_SI_UID
3552                {
3553                     SV *uid = newSV(0);
3554                     sv_setuid(uid, sip->si_uid);
3555                     (void)hv_stores(sih, "uid", uid);
3556                }
3557 #  endif
3558 #  ifdef HAS_SIGINFO_SI_PID
3559                (void)hv_stores(sih, "pid",        newSViv(sip->si_pid));
3560 #  endif
3561 #  ifdef HAS_SIGINFO_SI_ADDR
3562                (void)hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
3563 #  endif
3564 #  ifdef HAS_SIGINFO_SI_BAND
3565                (void)hv_stores(sih, "band",       newSViv(sip->si_band));
3566 #  endif
3567                EXTEND(SP, 2);
3568                PUSHs(rv);
3569                mPUSHp((char *)sip, sizeof(*sip));
3570
3571          }
3572     }
3573 #endif
3574
3575     PUTBACK;
3576
3577     errsv_save = newSVsv(ERRSV);
3578
3579     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
3580
3581     POPSTACK;
3582     {
3583         SV * const errsv = ERRSV;
3584         if (SvTRUE_NN(errsv)) {
3585             SvREFCNT_dec(errsv_save);
3586
3587 #ifndef PERL_MICRO
3588             /* Handler "died", for example to get out of a restart-able read().
3589              * Before we re-do that on its behalf re-enable the signal which was
3590              * blocked by the system when we entered.
3591              */
3592 #  ifdef HAS_SIGPROCMASK
3593             if (!safe) {
3594                 /* safe signals called via dispatch_signals() set up a
3595                  * savestack destructor, unblock_sigmask(), to
3596                  * automatically unblock the handler at the end. If
3597                  * instead we get here directly, we have to do it
3598                  * ourselves
3599                  */
3600                 sigset_t set;
3601                 sigemptyset(&set);
3602                 sigaddset(&set,sig);
3603                 sigprocmask(SIG_UNBLOCK, &set, NULL);
3604             }
3605 #  else
3606             /* Not clear if this will work */
3607             /* XXX not clear if this should be protected by 'if (safe)'
3608              * too */
3609
3610             (void)rsignal(sig, SIG_IGN);
3611             (void)rsignal(sig, PL_csighandlerp);
3612 #  endif
3613 #endif /* !PERL_MICRO */
3614
3615             die_sv(errsv);
3616         }
3617         else {
3618             sv_setsv(errsv, errsv_save);
3619             SvREFCNT_dec(errsv_save);
3620         }
3621     }
3622
3623   cleanup:
3624     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
3625     PL_savestack_ix = old_ss_ix;
3626     if (flags & 8)
3627         SvREFCNT_dec_NN(sv);
3628     PL_op = myop;                       /* Apparently not needed... */
3629
3630     PL_Sv = tSv;                        /* Restore global temporaries. */
3631     PL_Xpv = tXpv;
3632     return;
3633 }
3634
3635
3636 static void
3637 S_restore_magic(pTHX_ const void *p)
3638 {
3639     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3640     SV* const sv = mgs->mgs_sv;
3641     bool bumped;
3642
3643     if (!sv)
3644         return;
3645
3646     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
3647         SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
3648         if (mgs->mgs_flags)
3649             SvFLAGS(sv) |= mgs->mgs_flags;
3650         else
3651             mg_magical(sv);
3652     }
3653
3654     bumped = mgs->mgs_bumped;
3655     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3656
3657     /* If we're still on top of the stack, pop us off.  (That condition
3658      * will be satisfied if restore_magic was called explicitly, but *not*
3659      * if it's being called via leave_scope.)
3660      * The reason for doing this is that otherwise, things like sv_2cv()
3661      * may leave alloc gunk on the savestack, and some code
3662      * (e.g. sighandler) doesn't expect that...
3663      */
3664     if (PL_savestack_ix == mgs->mgs_ss_ix)
3665     {
3666         UV popval = SSPOPUV;
3667         assert(popval == SAVEt_DESTRUCTOR_X);
3668         PL_savestack_ix -= 2;
3669         popval = SSPOPUV;
3670         assert((popval & SAVE_MASK) == SAVEt_ALLOC);
3671         PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT;
3672     }
3673     if (bumped) {
3674         if (SvREFCNT(sv) == 1) {
3675             /* We hold the last reference to this SV, which implies that the
3676                SV was deleted as a side effect of the routines we called.
3677                So artificially keep it alive a bit longer.
3678                We avoid turning on the TEMP flag, which can cause the SV's
3679                buffer to get stolen (and maybe other stuff). */
3680             sv_2mortal(sv);
3681             SvTEMP_off(sv);
3682         }
3683         else
3684             SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */
3685     }
3686 }
3687
3688 /* clean up the mess created by Perl_sighandler().
3689  * Note that this is only called during an exit in a signal handler;
3690  * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually
3691  * skipped over. */
3692
3693 static void
3694 S_unwind_handler_stack(pTHX_ const void *p)
3695 {
3696     PERL_UNUSED_ARG(p);
3697
3698     PL_savestack_ix -= 5; /* Unprotect save in progress. */
3699 }
3700
3701 /*
3702 =for apidoc_section $magic
3703 =for apidoc magic_sethint
3704
3705 Triggered by a store to C<%^H>, records the key/value pair to
3706 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3707 anything that would need a deep copy.  Maybe we should warn if we find a
3708 reference.
3709
3710 =cut
3711 */
3712 int
3713 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3714 {
3715     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3716         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3717
3718     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3719
3720     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3721        an alternative leaf in there, with PL_compiling.cop_hints being used if
3722        it's NULL. If needed for threads, the alternative could lock a mutex,
3723        or take other more complex action.  */
3724
3725     /* Something changed in %^H, so it will need to be restored on scope exit.
3726        Doing this here saves a lot of doing it manually in perl code (and
3727        forgetting to do it, and consequent subtle errors.  */
3728     PL_hints |= HINT_LOCALIZE_HH;
3729     CopHINTHASH_set(&PL_compiling,
3730         cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0));
3731     magic_sethint_feature(key, NULL, 0, sv, 0);
3732     return 0;
3733 }
3734
3735 /*
3736 =for apidoc magic_clearhint
3737
3738 Triggered by a delete from C<%^H>, records the key to
3739 C<PL_compiling.cop_hints_hash>.
3740
3741 =cut
3742 */
3743 int
3744 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3745 {
3746     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3747     PERL_UNUSED_ARG(sv);
3748
3749     PL_hints |= HINT_LOCALIZE_HH;
3750     CopHINTHASH_set(&PL_compiling,
3751         mg->mg_len == HEf_SVKEY
3752          ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
3753                                  MUTABLE_SV(mg->mg_ptr), 0, 0)
3754          : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
3755                                  mg->mg_ptr, mg->mg_len, 0, 0));
3756     if (mg->mg_len == HEf_SVKEY)
3757         magic_sethint_feature(MUTABLE_SV(mg->mg_ptr), NULL, 0, NULL, FALSE);
3758     else
3759         magic_sethint_feature(NULL, mg->mg_ptr, mg->mg_len, NULL, FALSE);
3760     return 0;
3761 }
3762
3763 /*
3764 =for apidoc magic_clearhints
3765
3766 Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.
3767
3768 =cut
3769 */
3770 int
3771 Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
3772 {
3773     PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
3774     PERL_UNUSED_ARG(sv);
3775     PERL_UNUSED_ARG(mg);
3776     cophh_free(CopHINTHASH_get(&PL_compiling));
3777     CopHINTHASH_set(&PL_compiling, cophh_new_empty());
3778     CLEARFEATUREBITS();
3779     return 0;
3780 }
3781
3782 int
3783 Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
3784                                  const char *name, I32 namlen)
3785 {
3786     MAGIC *nmg;
3787
3788     PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
3789     PERL_UNUSED_ARG(sv);
3790     PERL_UNUSED_ARG(name);
3791     PERL_UNUSED_ARG(namlen);
3792
3793     sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
3794     nmg = mg_find(nsv, mg->mg_type);
3795     assert(nmg);
3796     if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
3797     nmg->mg_ptr = mg->mg_ptr;
3798     nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
3799     nmg->mg_flags |= MGf_REFCOUNTED;
3800     return 1;
3801 }
3802
3803 int
3804 Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3805     PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
3806
3807 #if DBVARMG_SINGLE != 0
3808     assert(mg->mg_private >= DBVARMG_SINGLE);
3809 #endif
3810     assert(mg->mg_private < DBVARMG_COUNT);
3811
3812     PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
3813
3814     return 1;
3815 }
3816
3817 int
3818 Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
3819     PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
3820
3821 #if DBVARMG_SINGLE != 0
3822     assert(mg->mg_private >= DBVARMG_SINGLE);
3823 #endif
3824     assert(mg->mg_private < DBVARMG_COUNT);
3825     sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
3826
3827     return 0;
3828 }
3829
3830 /*
3831  * ex: set ts=8 sts=4 sw=4 et:
3832  */