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