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