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