mg.c

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