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