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