mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 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
  16 /*
  17 =head1 Magical Functions
  18 */
  19
  20 #include "EXTERN.h"
  21 #define PERL_IN_MG_C
  22 #include "perl.h"
  23
  24 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
  25 #  ifndef NGROUPS
  26 #    define NGROUPS 32
  27 #  endif
  28 #  ifdef I_GRP
  29 #    include <grp.h>
  30 #  endif
  31 #endif
  32
  33 #ifdef __hpux
  34 #  include <sys/pstat.h>
  35 #endif
  36
  37 Signal_t Perl_csighandler(int sig);
  38
  39 /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
  40 #if !defined(HAS_SIGACTION) && defined(VMS)
  41 #  define  FAKE_PERSISTENT_SIGNAL_HANDLERS
  42 #endif
  43 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
  44 #if defined(KILL_BY_SIGPRC)
  45 #  define  FAKE_DEFAULT_SIGNAL_HANDLERS
  46 #endif
  47
  48 static void restore_magic(pTHX_ void *p);
  49 static void unwind_handler_stack(pTHX_ void *p);
  50
  51 /*
  52  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  53  */
  54
  55 struct magic_state {
  56     SV* mgs_sv;
  57     U32 mgs_flags;
  58     I32 mgs_ss_ix;
  59 };
  60 /* MGS is typedef'ed to struct magic_state in perl.h */
  61
  62 STATIC void
  63 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
  64 {
  65     MGS* mgs;
  66     assert(SvMAGICAL(sv));
  67 #ifdef PERL_COPY_ON_WRITE
  68     /* Turning READONLY off for a copy-on-write scalar is a bad idea.  */
  69     if (SvIsCOW(sv))
  70       sv_force_normal(sv);
  71 #endif
  72
  73     SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
  74
  75     mgs = SSPTR(mgs_ix, MGS*);
  76     mgs->mgs_sv = sv;
  77     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  78     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
  79
  80     SvMAGICAL_off(sv);
  81     SvREADONLY_off(sv);
  82     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
  83 }
  84
  85 /*
  86 =for apidoc mg_magical
  87
  88 Turns on the magical status of an SV.  See C<sv_magic>.
  89
  90 =cut
  91 */
  92
  93 void
  94 Perl_mg_magical(pTHX_ SV *sv)
  95 {
  96     MAGIC* mg;
  97     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
  98         MGVTBL* vtbl = mg->mg_virtual;
  99         if (vtbl) {
 100             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 101                 SvGMAGICAL_on(sv);
 102             if (vtbl->svt_set)
 103                 SvSMAGICAL_on(sv);
 104             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
 105                 SvRMAGICAL_on(sv);
 106         }
 107     }
 108 }
 109
 110 /*
 111 =for apidoc mg_get
 112
 113 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 114
 115 =cut
 116 */
 117
 118 int
 119 Perl_mg_get(pTHX_ SV *sv)
 120 {
 121     int new = 0;
 122     MAGIC *newmg, *head, *cur, *mg;
 123     I32 mgs_ix = SSNEW(sizeof(MGS));
 124
 125     save_magic(mgs_ix, sv);
 126
 127     /* We must call svt_get(sv, mg) for each valid entry in the linked
 128        list of magic. svt_get() may delete the current entry, add new
 129        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 130
 131     newmg = cur = head = mg = SvMAGIC(sv);
 132     while (mg) {
 133         MGVTBL *vtbl = mg->mg_virtual;
 134
 135         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 136             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 137
 138             /* guard against sv having been freed */
 139             if (SvTYPE(sv) == SVTYPEMASK) {
 140                 Perl_croak(aTHX_ "Tied variable freed while still in use");
 141             }
 142             /* guard against magic having been deleted - eg FETCH calling
 143              * untie */
 144             if (!SvMAGIC(sv))
 145                 break;
 146
 147             /* Don't restore the flags for this entry if it was deleted. */
 148             if (mg->mg_flags & MGf_GSKIP)
 149                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
 150         }
 151
 152         mg = mg->mg_moremagic;
 153
 154         if (new) {
 155             /* Have we finished with the new entries we saw? Start again
 156                where we left off (unless there are more new entries). */
 157             if (mg == head) {
 158                 new  = 0;
 159                 mg   = cur;
 160                 head = newmg;
 161             }
 162         }
 163
 164         /* Were any new entries added? */
 165         if (!new && (newmg = SvMAGIC(sv)) != head) {
 166             new = 1;
 167             cur = mg;
 168             mg  = newmg;
 169         }
 170     }
 171
 172     restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
 173     return 0;
 174 }
 175
 176 /*
 177 =for apidoc mg_set
 178
 179 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 180
 181 =cut
 182 */
 183
 184 int
 185 Perl_mg_set(pTHX_ SV *sv)
 186 {
 187     I32 mgs_ix;
 188     MAGIC* mg;
 189     MAGIC* nextmg;
 190
 191     mgs_ix = SSNEW(sizeof(MGS));
 192     save_magic(mgs_ix, sv);
 193
 194     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 195         MGVTBL* vtbl = mg->mg_virtual;
 196         nextmg = mg->mg_moremagic;      /* it may delete itself */
 197         if (mg->mg_flags & MGf_GSKIP) {
 198             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 199             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
 200         }
 201         if (vtbl && vtbl->svt_set)
 202             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
 203     }
 204
 205     restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
 206     return 0;
 207 }
 208
 209 /*
 210 =for apidoc mg_length
 211
 212 Report on the SV's length.  See C<sv_magic>.
 213
 214 =cut
 215 */
 216
 217 U32
 218 Perl_mg_length(pTHX_ SV *sv)
 219 {
 220     MAGIC* mg;
 221     STRLEN len;
 222
 223     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 224         MGVTBL* vtbl = mg->mg_virtual;
 225         if (vtbl && vtbl->svt_len) {
 226             I32 mgs_ix;
 227
 228             mgs_ix = SSNEW(sizeof(MGS));
 229             save_magic(mgs_ix, sv);
 230             /* omit MGf_GSKIP -- not changed here */
 231             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 232             restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
 233             return len;
 234         }
 235     }
 236
 237     if (DO_UTF8(sv))
 238     {
 239         U8 *s = (U8*)SvPV(sv, len);
 240         len = Perl_utf8_length(aTHX_ s, s + len);
 241     }
 242     else
 243         (void)SvPV(sv, len);
 244     return len;
 245 }
 246
 247 I32
 248 Perl_mg_size(pTHX_ SV *sv)
 249 {
 250     MAGIC* mg;
 251     I32 len;
 252
 253     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 254         MGVTBL* vtbl = mg->mg_virtual;
 255         if (vtbl && vtbl->svt_len) {
 256             I32 mgs_ix;
 257
 258             mgs_ix = SSNEW(sizeof(MGS));
 259             save_magic(mgs_ix, sv);
 260             /* omit MGf_GSKIP -- not changed here */
 261             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 262             restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
 263             return len;
 264         }
 265     }
 266
 267     switch(SvTYPE(sv)) {
 268         case SVt_PVAV:
 269             len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
 270             return len;
 271         case SVt_PVHV:
 272             /* FIXME */
 273         default:
 274             Perl_croak(aTHX_ "Size magic not implemented");
 275             break;
 276     }
 277     return 0;
 278 }
 279
 280 /*
 281 =for apidoc mg_clear
 282
 283 Clear something magical that the SV represents.  See C<sv_magic>.
 284
 285 =cut
 286 */
 287
 288 int
 289 Perl_mg_clear(pTHX_ SV *sv)
 290 {
 291     I32 mgs_ix;
 292     MAGIC* mg;
 293
 294     mgs_ix = SSNEW(sizeof(MGS));
 295     save_magic(mgs_ix, sv);
 296
 297     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 298         MGVTBL* vtbl = mg->mg_virtual;
 299         /* omit GSKIP -- never set here */
 300
 301         if (vtbl && vtbl->svt_clear)
 302             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 303     }
 304
 305     restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
 306     return 0;
 307 }
 308
 309 /*
 310 =for apidoc mg_find
 311
 312 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 313
 314 =cut
 315 */
 316
 317 MAGIC*
 318 Perl_mg_find(pTHX_ SV *sv, int type)
 319 {
 320     MAGIC* mg;
 321     if (!sv)
 322         return 0;
 323     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 324         if (mg->mg_type == type)
 325             return mg;
 326     }
 327     return 0;
 328 }
 329
 330 /*
 331 =for apidoc mg_copy
 332
 333 Copies the magic from one SV to another.  See C<sv_magic>.
 334
 335 =cut
 336 */
 337
 338 int
 339 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 340 {
 341     int count = 0;
 342     MAGIC* mg;
 343     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 344         MGVTBL* vtbl = mg->mg_virtual;
 345         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 346             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 347         }
 348         else if (isUPPER(mg->mg_type)) {
 349             sv_magic(nsv,
 350                      mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
 351                      (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
 352                                                         ? sv : mg->mg_obj,
 353                      toLOWER(mg->mg_type), key, klen);
 354             count++;
 355         }
 356     }
 357     return count;
 358 }
 359
 360 /*
 361 =for apidoc mg_free
 362
 363 Free any magic storage used by the SV.  See C<sv_magic>.
 364
 365 =cut
 366 */
 367
 368 int
 369 Perl_mg_free(pTHX_ SV *sv)
 370 {
 371     MAGIC* mg;
 372     MAGIC* moremagic;
 373     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 374         MGVTBL* vtbl = mg->mg_virtual;
 375         moremagic = mg->mg_moremagic;
 376         if (vtbl && vtbl->svt_free)
 377             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 378         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 379             if (mg->mg_len > 0)
 380                 Safefree(mg->mg_ptr);
 381             else if (mg->mg_len == HEf_SVKEY)
 382                 SvREFCNT_dec((SV*)mg->mg_ptr);
 383         }
 384         if (mg->mg_flags & MGf_REFCOUNTED)
 385             SvREFCNT_dec(mg->mg_obj);
 386         Safefree(mg);
 387     }
 388     SvMAGIC(sv) = 0;
 389     return 0;
 390 }
 391
 392
 393 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
 394 #include <signal.h>
 395 #endif
 396
 397 U32
 398 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 399 {
 400     register REGEXP *rx;
 401
 402     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 403         if (mg->mg_obj)         /* @+ */
 404             return rx->nparens;
 405         else                    /* @- */
 406             return rx->lastparen;
 407     }
 408
 409     return (U32)-1;
 410 }
 411
 412 int
 413 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 414 {
 415     register I32 paren;
 416     register I32 s;
 417     register I32 i;
 418     register REGEXP *rx;
 419     I32 t;
 420
 421     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 422         paren = mg->mg_len;
 423         if (paren < 0)
 424             return 0;
 425         if (paren <= (I32)rx->nparens &&
 426             (s = rx->startp[paren]) != -1 &&
 427             (t = rx->endp[paren]) != -1)
 428             {
 429                 if (mg->mg_obj)         /* @+ */
 430                     i = t;
 431                 else                    /* @- */
 432                     i = s;
 433
 434                 if (i > 0 && RX_MATCH_UTF8(rx)) {
 435                     char *b = rx->subbeg;
 436                     if (b)
 437                         i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
 438                 }
 439
 440                 sv_setiv(sv, i);
 441             }
 442     }
 443     return 0;
 444 }
 445
 446 int
 447 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 448 {
 449     Perl_croak(aTHX_ PL_no_modify);
 450     /* NOT REACHED */
 451     return 0;
 452 }
 453
 454 U32
 455 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 456 {
 457     register I32 paren;
 458     register I32 i;
 459     register REGEXP *rx;
 460     I32 s1, t1;
 461
 462     switch (*mg->mg_ptr) {
 463     case '1': case '2': case '3': case '4':
 464     case '5': case '6': case '7': case '8': case '9': case '&':
 465         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 466
 467             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 468           getparen:
 469             if (paren <= (I32)rx->nparens &&
 470                 (s1 = rx->startp[paren]) != -1 &&
 471                 (t1 = rx->endp[paren]) != -1)
 472             {
 473                 i = t1 - s1;
 474               getlen:
 475                 if (i > 0 && RX_MATCH_UTF8(rx)) {
 476                     char *s    = rx->subbeg + s1;
 477                     char *send = rx->subbeg + t1;
 478
 479                     i = t1 - s1;
 480                     if (is_utf8_string((U8*)s, i))
 481                         i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
 482                 }
 483                 if (i < 0)
 484                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 485                 return i;
 486             }
 487             else {
 488                 if (ckWARN(WARN_UNINITIALIZED))
 489                     report_uninit();
 490             }
 491         }
 492         else {
 493             if (ckWARN(WARN_UNINITIALIZED))
 494                 report_uninit();
 495         }
 496         return 0;
 497     case '+':
 498         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 499             paren = rx->lastparen;
 500             if (paren)
 501                 goto getparen;
 502         }
 503         return 0;
 504     case '\016': /* ^N */
 505         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 506             paren = rx->lastcloseparen;
 507             if (paren)
 508                 goto getparen;
 509         }
 510         return 0;
 511     case '`':
 512         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 513             if (rx->startp[0] != -1) {
 514                 i = rx->startp[0];
 515                 if (i > 0) {
 516                     s1 = 0;
 517                     t1 = i;
 518                     goto getlen;
 519                 }
 520             }
 521         }
 522         return 0;
 523     case '\'':
 524         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 525             if (rx->endp[0] != -1) {
 526                 i = rx->sublen - rx->endp[0];
 527                 if (i > 0) {
 528                     s1 = rx->endp[0];
 529                     t1 = rx->sublen;
 530                     goto getlen;
 531                 }
 532             }
 533         }
 534         return 0;
 535     }
 536     magic_get(sv,mg);
 537     if (!SvPOK(sv) && SvNIOK(sv)) {
 538         STRLEN n_a;
 539         sv_2pv(sv, &n_a);
 540     }
 541     if (SvPOK(sv))
 542         return SvCUR(sv);
 543     return 0;
 544 }
 545
 546 int
 547 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 548 {
 549     register I32 paren;
 550     register char *s;
 551     register I32 i;
 552     register REGEXP *rx;
 553
 554     switch (*mg->mg_ptr) {
 555     case '\001':                /* ^A */
 556         sv_setsv(sv, PL_bodytarget);
 557         break;
 558     case '\003':                /* ^C */
 559         sv_setiv(sv, (IV)PL_minus_c);
 560         break;
 561
 562     case '\004':                /* ^D */
 563         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 564 #if defined(YYDEBUG) && defined(DEBUGGING)
 565         PL_yydebug = DEBUG_p_TEST;
 566 #endif
 567         break;
 568     case '\005':  /* ^E */
 569          if (*(mg->mg_ptr+1) == '\0') {
 570 #ifdef MACOS_TRADITIONAL
 571              {
 572                   char msg[256];
 573
 574                   sv_setnv(sv,(double)gMacPerl_OSErr);
 575                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 576              }
 577 #else
 578 #ifdef VMS
 579              {
 580 #                 include <descrip.h>
 581 #                 include <starlet.h>
 582                   char msg[255];
 583                   $DESCRIPTOR(msgdsc,msg);
 584                   sv_setnv(sv,(NV) vaxc$errno);
 585                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 586                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 587                   else
 588                        sv_setpv(sv,"");
 589              }
 590 #else
 591 #ifdef OS2
 592              if (!(_emx_env & 0x200)) { /* Under DOS */
 593                   sv_setnv(sv, (NV)errno);
 594                   sv_setpv(sv, errno ? Strerror(errno) : "");
 595              } else {
 596                   if (errno != errno_isOS2) {
 597                        int tmp = _syserrno();
 598                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 599                             Perl_rc = tmp;
 600                   }
 601                   sv_setnv(sv, (NV)Perl_rc);
 602                   sv_setpv(sv, os2error(Perl_rc));
 603              }
 604 #else
 605 #ifdef WIN32
 606              {
 607                   DWORD dwErr = GetLastError();
 608                   sv_setnv(sv, (NV)dwErr);
 609                   if (dwErr)
 610                   {
 611                        PerlProc_GetOSError(sv, dwErr);
 612                   }
 613                   else
 614                        sv_setpv(sv, "");
 615                   SetLastError(dwErr);
 616              }
 617 #else
 618              sv_setnv(sv, (NV)errno);
 619              sv_setpv(sv, errno ? Strerror(errno) : "");
 620 #endif
 621 #endif
 622 #endif
 623 #endif
 624              SvNOK_on(sv);      /* what a wonderful hack! */
 625          }
 626          else if (strEQ(mg->mg_ptr+1, "NCODING"))
 627               sv_setsv(sv, PL_encoding);
 628          break;
 629     case '\006':                /* ^F */
 630         sv_setiv(sv, (IV)PL_maxsysfd);
 631         break;
 632     case '\010':                /* ^H */
 633         sv_setiv(sv, (IV)PL_hints);
 634         break;
 635     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 636         if (PL_inplace)
 637             sv_setpv(sv, PL_inplace);
 638         else
 639             sv_setsv(sv, &PL_sv_undef);
 640         break;
 641     case '\017':                /* ^O & ^OPEN */
 642         if (*(mg->mg_ptr+1) == '\0')
 643             sv_setpv(sv, PL_osname);
 644         else if (strEQ(mg->mg_ptr, "\017PEN")) {
 645             if (!PL_compiling.cop_io)
 646                 sv_setsv(sv, &PL_sv_undef);
 647             else {
 648                 sv_setsv(sv, PL_compiling.cop_io);
 649             }
 650         }
 651         break;
 652     case '\020':                /* ^P */
 653         sv_setiv(sv, (IV)PL_perldb);
 654         break;
 655     case '\023':                /* ^S */
 656         if (*(mg->mg_ptr+1) == '\0') {
 657             if (PL_lex_state != LEX_NOTPARSING)
 658                 (void)SvOK_off(sv);
 659             else if (PL_in_eval)
 660                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 661             else
 662                 sv_setiv(sv, 0);
 663         }
 664         break;
 665     case '\024':                /* ^T */
 666         if (*(mg->mg_ptr+1) == '\0') {
 667 #ifdef BIG_TIME
 668             sv_setnv(sv, PL_basetime);
 669 #else
 670             sv_setiv(sv, (IV)PL_basetime);
 671 #endif
 672         }
 673         else if (strEQ(mg->mg_ptr, "\024AINT"))
 674             sv_setiv(sv, PL_tainting
 675                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 676                     : 0);
 677         break;
 678     case '\025':                /* $^UNICODE */
 679         if (strEQ(mg->mg_ptr, "\025NICODE"))
 680             sv_setuv(sv, (UV) PL_unicode);
 681         break;
 682     case '\027':                /* ^W  & $^WARNING_BITS */
 683         if (*(mg->mg_ptr+1) == '\0')
 684             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 685         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
 686             if (PL_compiling.cop_warnings == pWARN_NONE ||
 687                 PL_compiling.cop_warnings == pWARN_STD)
 688             {
 689                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 690             }
 691             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 692                 /* Get the bit mask for $warnings::Bits{all}, because
 693                  * it could have been extended by warnings::register */
 694                 SV **bits_all;
 695                 HV *bits=get_hv("warnings::Bits", FALSE);
 696                 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
 697                     sv_setsv(sv, *bits_all);
 698                 }
 699                 else {
 700                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 701                 }
 702             }
 703             else {
 704                 sv_setsv(sv, PL_compiling.cop_warnings);
 705             }
 706             SvPOK_only(sv);
 707         }
 708         break;
 709     case '1': case '2': case '3': case '4':
 710     case '5': case '6': case '7': case '8': case '9': case '&':
 711         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 712             I32 s1, t1;
 713
 714             /*
 715              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 716              * XXX Does the new way break anything?
 717              */
 718             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 719           getparen:
 720             if (paren <= (I32)rx->nparens &&
 721                 (s1 = rx->startp[paren]) != -1 &&
 722                 (t1 = rx->endp[paren]) != -1)
 723             {
 724                 i = t1 - s1;
 725                 s = rx->subbeg + s1;
 726                 if (!rx->subbeg)
 727                     break;
 728
 729               getrx:
 730                 if (i >= 0) {
 731                     sv_setpvn(sv, s, i);
 732                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 733                         SvUTF8_on(sv);
 734                     else
 735                         SvUTF8_off(sv);
 736                     if (PL_tainting) {
 737                         if (RX_MATCH_TAINTED(rx)) {
 738                             MAGIC* mg = SvMAGIC(sv);
 739                             MAGIC* mgt;
 740                             PL_tainted = 1;
 741                             SvMAGIC(sv) = mg->mg_moremagic;
 742                             SvTAINT(sv);
 743                             if ((mgt = SvMAGIC(sv))) {
 744                                 mg->mg_moremagic = mgt;
 745                                 SvMAGIC(sv) = mg;
 746                             }
 747                         } else
 748                             SvTAINTED_off(sv);
 749                     }
 750                     break;
 751                 }
 752             }
 753         }
 754         sv_setsv(sv,&PL_sv_undef);
 755         break;
 756     case '+':
 757         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 758             paren = rx->lastparen;
 759             if (paren)
 760                 goto getparen;
 761         }
 762         sv_setsv(sv,&PL_sv_undef);
 763         break;
 764     case '\016':                /* ^N */
 765         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 766             paren = rx->lastcloseparen;
 767             if (paren)
 768                 goto getparen;
 769         }
 770         sv_setsv(sv,&PL_sv_undef);
 771         break;
 772     case '`':
 773         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 774             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 775                 i = rx->startp[0];
 776                 goto getrx;
 777             }
 778         }
 779         sv_setsv(sv,&PL_sv_undef);
 780         break;
 781     case '\'':
 782         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 783             if (rx->subbeg && rx->endp[0] != -1) {
 784                 s = rx->subbeg + rx->endp[0];
 785                 i = rx->sublen - rx->endp[0];
 786                 goto getrx;
 787             }
 788         }
 789         sv_setsv(sv,&PL_sv_undef);
 790         break;
 791     case '.':
 792 #ifndef lint
 793         if (GvIO(PL_last_in_gv)) {
 794             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 795         }
 796 #endif
 797         break;
 798     case '?':
 799         {
 800             sv_setiv(sv, (IV)STATUS_CURRENT);
 801 #ifdef COMPLEX_STATUS
 802             LvTARGOFF(sv) = PL_statusvalue;
 803             LvTARGLEN(sv) = PL_statusvalue_vms;
 804 #endif
 805         }
 806         break;
 807     case '^':
 808         s = IoTOP_NAME(GvIOp(PL_defoutgv));
 809         if (s)
 810             sv_setpv(sv,s);
 811         else {
 812             sv_setpv(sv,GvENAME(PL_defoutgv));
 813             sv_catpv(sv,"_TOP");
 814         }
 815         break;
 816     case '~':
 817         s = IoFMT_NAME(GvIOp(PL_defoutgv));
 818         if (!s)
 819             s = GvENAME(PL_defoutgv);
 820         sv_setpv(sv,s);
 821         break;
 822 #ifndef lint
 823     case '=':
 824         sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 825         break;
 826     case '-':
 827         sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 828         break;
 829     case '%':
 830         sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 831         break;
 832 #endif
 833     case ':':
 834         break;
 835     case '/':
 836         break;
 837     case '[':
 838         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 839         break;
 840     case '|':
 841         sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 842         break;
 843     case ',':
 844         break;
 845     case '\\':
 846         if (PL_ors_sv)
 847             sv_copypv(sv, PL_ors_sv);
 848         break;
 849     case '#':
 850         sv_setpv(sv,PL_ofmt);
 851         break;
 852     case '!':
 853 #ifdef VMS
 854         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 855         sv_setpv(sv, errno ? Strerror(errno) : "");
 856 #else
 857         {
 858         int saveerrno = errno;
 859         sv_setnv(sv, (NV)errno);
 860 #ifdef OS2
 861         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 862             sv_setpv(sv, os2error(Perl_rc));
 863         else
 864 #endif
 865         sv_setpv(sv, errno ? Strerror(errno) : "");
 866         errno = saveerrno;
 867         }
 868 #endif
 869         SvNOK_on(sv);   /* what a wonderful hack! */
 870         break;
 871     case '<':
 872         sv_setiv(sv, (IV)PL_uid);
 873         break;
 874     case '>':
 875         sv_setiv(sv, (IV)PL_euid);
 876         break;
 877     case '(':
 878         sv_setiv(sv, (IV)PL_gid);
 879 #ifdef HAS_GETGROUPS
 880         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
 881 #endif
 882         goto add_groups;
 883     case ')':
 884         sv_setiv(sv, (IV)PL_egid);
 885 #ifdef HAS_GETGROUPS
 886         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
 887 #endif
 888       add_groups:
 889 #ifdef HAS_GETGROUPS
 890         {
 891             Groups_t gary[NGROUPS];
 892             i = getgroups(NGROUPS,gary);
 893             while (--i >= 0)
 894                 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
 895         }
 896 #endif
 897         (void)SvIOK_on(sv);     /* what a wonderful hack! */
 898         break;
 899 #ifndef MACOS_TRADITIONAL
 900     case '0':
 901         break;
 902 #endif
 903     }
 904     return 0;
 905 }
 906
 907 int
 908 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
 909 {
 910     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
 911
 912     if (uf && uf->uf_val)
 913         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
 914     return 0;
 915 }
 916
 917 int
 918 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 919 {
 920     register char *s;
 921     char *ptr;
 922     STRLEN len, klen;
 923
 924     s = SvPV(sv,len);
 925     ptr = MgPV(mg,klen);
 926     my_setenv(ptr, s);
 927
 928 #ifdef DYNAMIC_ENV_FETCH
 929      /* We just undefd an environment var.  Is a replacement */
 930      /* waiting in the wings? */
 931     if (!len) {
 932         SV **valp;
 933         if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
 934             s = SvPV(*valp, len);
 935     }
 936 #endif
 937
 938 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
 939                             /* And you'll never guess what the dog had */
 940                             /*   in its mouth... */
 941     if (PL_tainting) {
 942         MgTAINTEDDIR_off(mg);
 943 #ifdef VMS
 944         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
 945             char pathbuf[256], eltbuf[256], *cp, *elt = s;
 946             Stat_t sbuf;
 947             int i = 0, j = 0;
 948
 949             do {          /* DCL$PATH may be a search list */
 950                 while (1) {   /* as may dev portion of any element */
 951                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
 952                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
 953                              cando_by_name(S_IWUSR,0,elt) ) {
 954                             MgTAINTEDDIR_on(mg);
 955                             return 0;
 956                         }
 957                     }
 958                     if ((cp = strchr(elt, ':')) != Nullch)
 959                         *cp = '\0';
 960                     if (my_trnlnm(elt, eltbuf, j++))
 961                         elt = eltbuf;
 962                     else
 963                         break;
 964                 }
 965                 j = 0;
 966             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
 967         }
 968 #endif /* VMS */
 969         if (s && klen == 4 && strEQ(ptr,"PATH")) {
 970             char *strend = s + len;
 971
 972             while (s < strend) {
 973                 char tmpbuf[256];
 974                 Stat_t st;
 975                 I32 i;
 976                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
 977                              s, strend, ':', &i);
 978                 s++;
 979                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
 980                       || *tmpbuf != '/'
 981                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
 982                     MgTAINTEDDIR_on(mg);
 983                     return 0;
 984                 }
 985             }
 986         }
 987     }
 988 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
 989
 990     return 0;
 991 }
 992
 993 int
 994 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
 995 {
 996     STRLEN n_a;
 997     my_setenv(MgPV(mg,n_a),Nullch);
 998     return 0;
 999 }
1000
1001 int
1002 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1003 {
1004 #if defined(VMS)
1005     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1006 #else
1007     if (PL_localizing) {
1008         HE* entry;
1009         STRLEN n_a;
1010         magic_clear_all_env(sv,mg);
1011         hv_iterinit((HV*)sv);
1012         while ((entry = hv_iternext((HV*)sv))) {
1013             I32 keylen;
1014             my_setenv(hv_iterkey(entry, &keylen),
1015                       SvPV(hv_iterval((HV*)sv, entry), n_a));
1016         }
1017     }
1018 #endif
1019     return 0;
1020 }
1021
1022 int
1023 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1024 {
1025 #ifndef PERL_MICRO
1026 #if defined(VMS) || defined(EPOC)
1027     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1028 #else
1029 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1030     PerlEnv_clearenv();
1031 #  else
1032 #    ifdef USE_ENVIRON_ARRAY
1033 #      if defined(USE_ITHREADS)
1034     /* only the parent thread can clobber the process environment */
1035     if (PL_curinterp == aTHX)
1036 #      endif
1037     {
1038 #      ifndef PERL_USE_SAFE_PUTENV
1039     I32 i;
1040
1041     if (environ == PL_origenviron)
1042         environ = (char**)safesysmalloc(sizeof(char*));
1043     else
1044         for (i = 0; environ[i]; i++)
1045             safesysfree(environ[i]);
1046 #      endif /* PERL_USE_SAFE_PUTENV */
1047
1048     environ[0] = Nullch;
1049     }
1050 #    endif /* USE_ENVIRON_ARRAY */
1051 #   endif /* PERL_IMPLICIT_SYS || WIN32 */
1052 #endif /* VMS || EPOC */
1053 #endif /* !PERL_MICRO */
1054     return 0;
1055 }
1056
1057 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1058 static int sig_handlers_initted = 0;
1059 #endif
1060 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1061 static int sig_ignoring[SIG_SIZE];      /* which signals we are ignoring */
1062 #endif
1063 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1064 static int sig_defaulting[SIG_SIZE];
1065 #endif
1066
1067 #ifndef PERL_MICRO
1068 #ifdef HAS_SIGPROCMASK
1069 static void
1070 restore_sigmask(pTHX_ SV *save_sv)
1071 {
1072     sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
1073     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1074 }
1075 #endif
1076 int
1077 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1078 {
1079     I32 i;
1080     STRLEN n_a;
1081     /* Are we fetching a signal entry? */
1082     i = whichsig(MgPV(mg,n_a));
1083     if (i > 0) {
1084         if(PL_psig_ptr[i])
1085             sv_setsv(sv,PL_psig_ptr[i]);
1086         else {
1087             Sighandler_t sigstate;
1088             sigstate = rsignal_state(i);
1089 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1090             if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1091 #endif
1092 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1093             if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1094 #endif
1095             /* cache state so we don't fetch it again */
1096             if(sigstate == SIG_IGN)
1097                 sv_setpv(sv,"IGNORE");
1098             else
1099                 sv_setsv(sv,&PL_sv_undef);
1100             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1101             SvTEMP_off(sv);
1102         }
1103     }
1104     return 0;
1105 }
1106 int
1107 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1108 {
1109     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1110      * refactoring might be in order.
1111      */
1112     register char *s;
1113     STRLEN n_a;
1114     SV* to_dec;
1115     s = MgPV(mg,n_a);
1116     if (*s == '_') {
1117         SV** svp;
1118         if (strEQ(s,"__DIE__"))
1119             svp = &PL_diehook;
1120         else if (strEQ(s,"__WARN__"))
1121             svp = &PL_warnhook;
1122         else
1123             Perl_croak(aTHX_ "No such hook: %s", s);
1124         if (*svp) {
1125             to_dec = *svp;
1126             *svp = 0;
1127             SvREFCNT_dec(to_dec);
1128         }
1129     }
1130     else {
1131         I32 i;
1132         /* Are we clearing a signal entry? */
1133         i = whichsig(s);
1134         if (i > 0) {
1135 #ifdef HAS_SIGPROCMASK
1136             sigset_t set, save;
1137             SV* save_sv;
1138             /* Avoid having the signal arrive at a bad time, if possible. */
1139             sigemptyset(&set);
1140             sigaddset(&set,i);
1141             sigprocmask(SIG_BLOCK, &set, &save);
1142             ENTER;
1143             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1144             SAVEFREESV(save_sv);
1145             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1146 #endif
1147             PERL_ASYNC_CHECK();
1148 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1149             if (!sig_handlers_initted) Perl_csighandler_init();
1150 #endif
1151 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1152             sig_defaulting[i] = 1;
1153             (void)rsignal(i, PL_csighandlerp);
1154 #else
1155             (void)rsignal(i, SIG_DFL);
1156 #endif
1157             if(PL_psig_name[i]) {
1158                 SvREFCNT_dec(PL_psig_name[i]);
1159                 PL_psig_name[i]=0;
1160             }
1161             if(PL_psig_ptr[i]) {
1162                 to_dec=PL_psig_ptr[i];
1163                 PL_psig_ptr[i]=0;
1164                 LEAVE;
1165                 SvREFCNT_dec(to_dec);
1166             }
1167             else
1168                 LEAVE;
1169         }
1170     }
1171     return 0;
1172 }
1173
1174 void
1175 Perl_raise_signal(pTHX_ int sig)
1176 {
1177     /* Set a flag to say this signal is pending */
1178     PL_psig_pend[sig]++;
1179     /* And one to say _a_ signal is pending */
1180     PL_sig_pending = 1;
1181 }
1182
1183 Signal_t
1184 Perl_csighandler(int sig)
1185 {
1186 #ifdef PERL_GET_SIG_CONTEXT
1187     dTHXa(PERL_GET_SIG_CONTEXT);
1188 #else
1189     dTHX;
1190 #endif
1191 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1192     (void) rsignal(sig, PL_csighandlerp);
1193     if (sig_ignoring[sig]) return;
1194 #endif
1195 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1196     if (sig_defaulting[sig])
1197 #ifdef KILL_BY_SIGPRC
1198             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1199 #else
1200             exit(1);
1201 #endif
1202 #endif
1203    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1204         /* Call the perl level handler now--
1205          * with risk we may be in malloc() etc. */
1206         (*PL_sighandlerp)(sig);
1207    else
1208         Perl_raise_signal(aTHX_ sig);
1209 }
1210
1211 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1212 void
1213 Perl_csighandler_init(void)
1214 {
1215     int sig;
1216     if (sig_handlers_initted) return;
1217
1218     for (sig = 1; sig < SIG_SIZE; sig++) {
1219 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1220         dTHX;
1221         sig_defaulting[sig] = 1;
1222         (void) rsignal(sig, PL_csighandlerp);
1223 #endif
1224 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1225         sig_ignoring[sig] = 0;
1226 #endif
1227     }
1228     sig_handlers_initted = 1;
1229 }
1230 #endif
1231
1232 void
1233 Perl_despatch_signals(pTHX)
1234 {
1235     int sig;
1236     PL_sig_pending = 0;
1237     for (sig = 1; sig < SIG_SIZE; sig++) {
1238         if (PL_psig_pend[sig]) {
1239             PERL_BLOCKSIG_ADD(set, sig);
1240             PL_psig_pend[sig] = 0;
1241             PERL_BLOCKSIG_BLOCK(set);
1242             (*PL_sighandlerp)(sig);
1243             PERL_BLOCKSIG_UNBLOCK(set);
1244         }
1245     }
1246 }
1247
1248 int
1249 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1250 {
1251     register char *s;
1252     I32 i;
1253     SV** svp = 0;
1254     /* Need to be careful with SvREFCNT_dec(), because that can have side
1255      * effects (due to closures). We must make sure that the new disposition
1256      * is in place before it is called.
1257      */
1258     SV* to_dec = 0;
1259     STRLEN len;
1260 #ifdef HAS_SIGPROCMASK
1261     sigset_t set, save;
1262     SV* save_sv;
1263 #endif
1264
1265     s = MgPV(mg,len);
1266     if (*s == '_') {
1267         if (strEQ(s,"__DIE__"))
1268             svp = &PL_diehook;
1269         else if (strEQ(s,"__WARN__"))
1270             svp = &PL_warnhook;
1271         else
1272             Perl_croak(aTHX_ "No such hook: %s", s);
1273         i = 0;
1274         if (*svp) {
1275             to_dec = *svp;
1276             *svp = 0;
1277         }
1278     }
1279     else {
1280         i = whichsig(s);        /* ...no, a brick */
1281         if (i < 0) {
1282             if (ckWARN(WARN_SIGNAL))
1283                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1284             return 0;
1285         }
1286 #ifdef HAS_SIGPROCMASK
1287         /* Avoid having the signal arrive at a bad time, if possible. */
1288         sigemptyset(&set);
1289         sigaddset(&set,i);
1290         sigprocmask(SIG_BLOCK, &set, &save);
1291         ENTER;
1292         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1293         SAVEFREESV(save_sv);
1294         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1295 #endif
1296         PERL_ASYNC_CHECK();
1297 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1298         if (!sig_handlers_initted) Perl_csighandler_init();
1299 #endif
1300 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1301         sig_ignoring[i] = 0;
1302 #endif
1303 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1304         sig_defaulting[i] = 0;
1305 #endif
1306         SvREFCNT_dec(PL_psig_name[i]);
1307         to_dec = PL_psig_ptr[i];
1308         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1309         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1310         PL_psig_name[i] = newSVpvn(s, len);
1311         SvREADONLY_on(PL_psig_name[i]);
1312     }
1313     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1314         if (i) {
1315             (void)rsignal(i, PL_csighandlerp);
1316 #ifdef HAS_SIGPROCMASK
1317             LEAVE;
1318 #endif
1319         }
1320         else
1321             *svp = SvREFCNT_inc(sv);
1322         if(to_dec)
1323             SvREFCNT_dec(to_dec);
1324         return 0;
1325     }
1326     s = SvPV_force(sv,len);
1327     if (strEQ(s,"IGNORE")) {
1328         if (i) {
1329 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1330             sig_ignoring[i] = 1;
1331             (void)rsignal(i, PL_csighandlerp);
1332 #else
1333             (void)rsignal(i, SIG_IGN);
1334 #endif
1335         }
1336     }
1337     else if (strEQ(s,"DEFAULT") || !*s) {
1338         if (i)
1339 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1340           {
1341             sig_defaulting[i] = 1;
1342             (void)rsignal(i, PL_csighandlerp);
1343           }
1344 #else
1345             (void)rsignal(i, SIG_DFL);
1346 #endif
1347     }
1348     else {
1349         /*
1350          * We should warn if HINT_STRICT_REFS, but without
1351          * access to a known hint bit in a known OP, we can't
1352          * tell whether HINT_STRICT_REFS is in force or not.
1353          */
1354         if (!strchr(s,':') && !strchr(s,'\''))
1355             sv_insert(sv, 0, 0, "main::", 6);
1356         if (i)
1357             (void)rsignal(i, PL_csighandlerp);
1358         else
1359             *svp = SvREFCNT_inc(sv);
1360     }
1361 #ifdef HAS_SIGPROCMASK
1362     if(i)
1363         LEAVE;
1364 #endif
1365     if(to_dec)
1366         SvREFCNT_dec(to_dec);
1367     return 0;
1368 }
1369 #endif /* !PERL_MICRO */
1370
1371 int
1372 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1373 {
1374     PL_sub_generation++;
1375     return 0;
1376 }
1377
1378 int
1379 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1380 {
1381     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1382     PL_amagic_generation++;
1383
1384     return 0;
1385 }
1386
1387 int
1388 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1389 {
1390     HV *hv = (HV*)LvTARG(sv);
1391     I32 i = 0;
1392
1393     if (hv) {
1394          (void) hv_iterinit(hv);
1395          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1396              i = HvKEYS(hv);
1397          else {
1398              while (hv_iternext(hv))
1399                  i++;
1400          }
1401     }
1402
1403     sv_setiv(sv, (IV)i);
1404     return 0;
1405 }
1406
1407 int
1408 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1409 {
1410     if (LvTARG(sv)) {
1411         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1412     }
1413     return 0;
1414 }
1415
1416 /* caller is responsible for stack switching/cleanup */
1417 STATIC int
1418 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1419 {
1420     dSP;
1421
1422     PUSHMARK(SP);
1423     EXTEND(SP, n);
1424     PUSHs(SvTIED_obj(sv, mg));
1425     if (n > 1) {
1426         if (mg->mg_ptr) {
1427             if (mg->mg_len >= 0)
1428                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1429             else if (mg->mg_len == HEf_SVKEY)
1430                 PUSHs((SV*)mg->mg_ptr);
1431         }
1432         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1433             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1434         }
1435     }
1436     if (n > 2) {
1437         PUSHs(val);
1438     }
1439     PUTBACK;
1440
1441     return call_method(meth, flags);
1442 }
1443
1444 STATIC int
1445 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1446 {
1447     dSP;
1448
1449     ENTER;
1450     SAVETMPS;
1451     PUSHSTACKi(PERLSI_MAGIC);
1452
1453     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1454         sv_setsv(sv, *PL_stack_sp--);
1455     }
1456
1457     POPSTACK;
1458     FREETMPS;
1459     LEAVE;
1460     return 0;
1461 }
1462
1463 int
1464 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1465 {
1466     if (mg->mg_ptr)
1467         mg->mg_flags |= MGf_GSKIP;
1468     magic_methpack(sv,mg,"FETCH");
1469     return 0;
1470 }
1471
1472 int
1473 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1474 {
1475     dSP;
1476     ENTER;
1477     PUSHSTACKi(PERLSI_MAGIC);
1478     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1479     POPSTACK;
1480     LEAVE;
1481     return 0;
1482 }
1483
1484 int
1485 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1486 {
1487     return magic_methpack(sv,mg,"DELETE");
1488 }
1489
1490
1491 U32
1492 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1493 {
1494     dSP;
1495     U32 retval = 0;
1496
1497     ENTER;
1498     SAVETMPS;
1499     PUSHSTACKi(PERLSI_MAGIC);
1500     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1501         sv = *PL_stack_sp--;
1502         retval = (U32) SvIV(sv)-1;
1503     }
1504     POPSTACK;
1505     FREETMPS;
1506     LEAVE;
1507     return retval;
1508 }
1509
1510 int
1511 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1512 {
1513     dSP;
1514
1515     ENTER;
1516     PUSHSTACKi(PERLSI_MAGIC);
1517     PUSHMARK(SP);
1518     XPUSHs(SvTIED_obj(sv, mg));
1519     PUTBACK;
1520     call_method("CLEAR", G_SCALAR|G_DISCARD);
1521     POPSTACK;
1522     LEAVE;
1523     return 0;
1524 }
1525
1526 int
1527 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1528 {
1529     dSP;
1530     const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1531
1532     ENTER;
1533     SAVETMPS;
1534     PUSHSTACKi(PERLSI_MAGIC);
1535     PUSHMARK(SP);
1536     EXTEND(SP, 2);
1537     PUSHs(SvTIED_obj(sv, mg));
1538     if (SvOK(key))
1539         PUSHs(key);
1540     PUTBACK;
1541
1542     if (call_method(meth, G_SCALAR))
1543         sv_setsv(key, *PL_stack_sp--);
1544
1545     POPSTACK;
1546     FREETMPS;
1547     LEAVE;
1548     return 0;
1549 }
1550
1551 int
1552 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1553 {
1554     return magic_methpack(sv,mg,"EXISTS");
1555 }
1556
1557 int
1558 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1559 {
1560     OP *o;
1561     I32 i;
1562     GV* gv;
1563     SV** svp;
1564     STRLEN n_a;
1565
1566     gv = PL_DBline;
1567     i = SvTRUE(sv);
1568     svp = av_fetch(GvAV(gv),
1569                      atoi(MgPV(mg,n_a)), FALSE);
1570     if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
1571         /* set or clear breakpoint in the relevant control op */
1572         if (i)
1573             o->op_flags |= OPf_SPECIAL;
1574         else
1575             o->op_flags &= ~OPf_SPECIAL;
1576     }
1577     return 0;
1578 }
1579
1580 int
1581 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1582 {
1583     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1584     return 0;
1585 }
1586
1587 int
1588 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1589 {
1590     av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1591     return 0;
1592 }
1593
1594 int
1595 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1596 {
1597     SV* lsv = LvTARG(sv);
1598
1599     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1600         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1601         if (mg && mg->mg_len >= 0) {
1602             I32 i = mg->mg_len;
1603             if (DO_UTF8(lsv))
1604                 sv_pos_b2u(lsv, &i);
1605             sv_setiv(sv, i + PL_curcop->cop_arybase);
1606             return 0;
1607         }
1608     }
1609     (void)SvOK_off(sv);
1610     return 0;
1611 }
1612
1613 int
1614 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1615 {
1616     SV* lsv = LvTARG(sv);
1617     SSize_t pos;
1618     STRLEN len;
1619     STRLEN ulen = 0;
1620
1621     mg = 0;
1622
1623     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1624         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1625     if (!mg) {
1626         if (!SvOK(sv))
1627             return 0;
1628         sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1629         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1630     }
1631     else if (!SvOK(sv)) {
1632         mg->mg_len = -1;
1633         return 0;
1634     }
1635     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1636
1637     pos = SvIV(sv) - PL_curcop->cop_arybase;
1638
1639     if (DO_UTF8(lsv)) {
1640         ulen = sv_len_utf8(lsv);
1641         if (ulen)
1642             len = ulen;
1643     }
1644
1645     if (pos < 0) {
1646         pos += len;
1647         if (pos < 0)
1648             pos = 0;
1649     }
1650     else if (pos > (SSize_t)len)
1651         pos = len;
1652
1653     if (ulen) {
1654         I32 p = pos;
1655         sv_pos_u2b(lsv, &p, 0);
1656         pos = p;
1657     }
1658
1659     mg->mg_len = pos;
1660     mg->mg_flags &= ~MGf_MINMATCH;
1661
1662     return 0;
1663 }
1664
1665 int
1666 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1667 {
1668     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1669         SvFAKE_off(sv);
1670         gv_efullname3(sv,((GV*)sv), "*");
1671         SvFAKE_on(sv);
1672     }
1673     else
1674         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1675     return 0;
1676 }
1677
1678 int
1679 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1680 {
1681     register char *s;
1682     GV* gv;
1683     STRLEN n_a;
1684
1685     if (!SvOK(sv))
1686         return 0;
1687     s = SvPV(sv, n_a);
1688     if (*s == '*' && s[1])
1689         s++;
1690     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1691     if (sv == (SV*)gv)
1692         return 0;
1693     if (GvGP(sv))
1694         gp_free((GV*)sv);
1695     GvGP(sv) = gp_ref(GvGP(gv));
1696     return 0;
1697 }
1698
1699 int
1700 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1701 {
1702     STRLEN len;
1703     SV *lsv = LvTARG(sv);
1704     char *tmps = SvPV(lsv,len);
1705     I32 offs = LvTARGOFF(sv);
1706     I32 rem = LvTARGLEN(sv);
1707
1708     if (SvUTF8(lsv))
1709         sv_pos_u2b(lsv, &offs, &rem);
1710     if (offs > (I32)len)
1711         offs = len;
1712     if (rem + offs > (I32)len)
1713         rem = len - offs;
1714     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1715     if (SvUTF8(lsv))
1716         SvUTF8_on(sv);
1717     return 0;
1718 }
1719
1720 int
1721 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1722 {
1723     STRLEN len;
1724     char *tmps = SvPV(sv, len);
1725     SV *lsv = LvTARG(sv);
1726     I32 lvoff = LvTARGOFF(sv);
1727     I32 lvlen = LvTARGLEN(sv);
1728
1729     if (DO_UTF8(sv)) {
1730         sv_utf8_upgrade(lsv);
1731         sv_pos_u2b(lsv, &lvoff, &lvlen);
1732         sv_insert(lsv, lvoff, lvlen, tmps, len);
1733         SvUTF8_on(lsv);
1734     }
1735     else if (lsv && SvUTF8(lsv)) {
1736         sv_pos_u2b(lsv, &lvoff, &lvlen);
1737         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1738         sv_insert(lsv, lvoff, lvlen, tmps, len);
1739         Safefree(tmps);
1740     }
1741     else
1742         sv_insert(lsv, lvoff, lvlen, tmps, len);
1743
1744     return 0;
1745 }
1746
1747 int
1748 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1749 {
1750     TAINT_IF((mg->mg_len & 1) ||
1751              ((mg->mg_len & 2) && mg->mg_obj == sv));   /* kludge */
1752     return 0;
1753 }
1754
1755 int
1756 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1757 {
1758     if (PL_localizing) {
1759         if (PL_localizing == 1)
1760             mg->mg_len <<= 1;
1761         else
1762             mg->mg_len >>= 1;
1763     }
1764     else if (PL_tainted)
1765         mg->mg_len |= 1;
1766     else
1767         mg->mg_len &= ~1;
1768     return 0;
1769 }
1770
1771 int
1772 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1773 {
1774     SV *lsv = LvTARG(sv);
1775
1776     if (!lsv) {
1777         (void)SvOK_off(sv);
1778         return 0;
1779     }
1780
1781     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1782     return 0;
1783 }
1784
1785 int
1786 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1787 {
1788     do_vecset(sv);      /* XXX slurp this routine */
1789     return 0;
1790 }
1791
1792 int
1793 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1794 {
1795     SV *targ = Nullsv;
1796     if (LvTARGLEN(sv)) {
1797         if (mg->mg_obj) {
1798             SV *ahv = LvTARG(sv);
1799             HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1800             if (he)
1801                 targ = HeVAL(he);
1802         }
1803         else {
1804             AV* av = (AV*)LvTARG(sv);
1805             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1806                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1807         }
1808         if (targ && targ != &PL_sv_undef) {
1809             /* somebody else defined it for us */
1810             SvREFCNT_dec(LvTARG(sv));
1811             LvTARG(sv) = SvREFCNT_inc(targ);
1812             LvTARGLEN(sv) = 0;
1813             SvREFCNT_dec(mg->mg_obj);
1814             mg->mg_obj = Nullsv;
1815             mg->mg_flags &= ~MGf_REFCOUNTED;
1816         }
1817     }
1818     else
1819         targ = LvTARG(sv);
1820     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1821     return 0;
1822 }
1823
1824 int
1825 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1826 {
1827     if (LvTARGLEN(sv))
1828         vivify_defelem(sv);
1829     if (LvTARG(sv)) {
1830         sv_setsv(LvTARG(sv), sv);
1831         SvSETMAGIC(LvTARG(sv));
1832     }
1833     return 0;
1834 }
1835
1836 void
1837 Perl_vivify_defelem(pTHX_ SV *sv)
1838 {
1839     MAGIC *mg;
1840     SV *value = Nullsv;
1841
1842     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1843         return;
1844     if (mg->mg_obj) {
1845         SV *ahv = LvTARG(sv);
1846         STRLEN n_a;
1847         HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1848         if (he)
1849             value = HeVAL(he);
1850         if (!value || value == &PL_sv_undef)
1851             Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1852     }
1853     else {
1854         AV* av = (AV*)LvTARG(sv);
1855         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1856             LvTARG(sv) = Nullsv;        /* array can't be extended */
1857         else {
1858             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1859             if (!svp || (value = *svp) == &PL_sv_undef)
1860                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1861         }
1862     }
1863     (void)SvREFCNT_inc(value);
1864     SvREFCNT_dec(LvTARG(sv));
1865     LvTARG(sv) = value;
1866     LvTARGLEN(sv) = 0;
1867     SvREFCNT_dec(mg->mg_obj);
1868     mg->mg_obj = Nullsv;
1869     mg->mg_flags &= ~MGf_REFCOUNTED;
1870 }
1871
1872 int
1873 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1874 {
1875     AV *av = (AV*)mg->mg_obj;
1876     SV **svp = AvARRAY(av);
1877     I32 i = AvFILLp(av);
1878     while (i >= 0) {
1879         if (svp[i] && svp[i] != &PL_sv_undef) {
1880             if (!SvWEAKREF(svp[i]))
1881                 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1882             /* XXX Should we check that it hasn't changed? */
1883             SvRV(svp[i]) = 0;
1884             (void)SvOK_off(svp[i]);
1885             SvWEAKREF_off(svp[i]);
1886             svp[i] = &PL_sv_undef;
1887         }
1888         i--;
1889     }
1890     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1891     return 0;
1892 }
1893
1894 int
1895 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1896 {
1897     mg->mg_len = -1;
1898     SvSCREAM_off(sv);
1899     return 0;
1900 }
1901
1902 int
1903 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1904 {
1905     sv_unmagic(sv, PERL_MAGIC_bm);
1906     SvVALID_off(sv);
1907     return 0;
1908 }
1909
1910 int
1911 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1912 {
1913     sv_unmagic(sv, PERL_MAGIC_fm);
1914     SvCOMPILED_off(sv);
1915     return 0;
1916 }
1917
1918 int
1919 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
1920 {
1921     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1922
1923     if (uf && uf->uf_set)
1924         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
1925     return 0;
1926 }
1927
1928 int
1929 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
1930 {
1931     sv_unmagic(sv, PERL_MAGIC_qr);
1932     return 0;
1933 }
1934
1935 int
1936 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
1937 {
1938     regexp *re = (regexp *)mg->mg_obj;
1939     ReREFCNT_dec(re);
1940     return 0;
1941 }
1942
1943 #ifdef USE_LOCALE_COLLATE
1944 int
1945 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
1946 {
1947     /*
1948      * RenE<eacute> Descartes said "I think not."
1949      * and vanished with a faint plop.
1950      */
1951     if (mg->mg_ptr) {
1952         Safefree(mg->mg_ptr);
1953         mg->mg_ptr = NULL;
1954         mg->mg_len = -1;
1955     }
1956     return 0;
1957 }
1958 #endif /* USE_LOCALE_COLLATE */
1959
1960 /* Just clear the UTF-8 cache data. */
1961 int
1962 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
1963 {
1964     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
1965     mg->mg_ptr = 0;
1966     mg->mg_len = -1;            /* The mg_len holds the len cache. */
1967     return 0;
1968 }
1969
1970 int
1971 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
1972 {
1973     register char *s;
1974     I32 i;
1975     STRLEN len;
1976     switch (*mg->mg_ptr) {
1977     case '\001':        /* ^A */
1978         sv_setsv(PL_bodytarget, sv);
1979         break;
1980     case '\003':        /* ^C */
1981         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1982         break;
1983
1984     case '\004':        /* ^D */
1985 #ifdef DEBUGGING
1986         s = SvPV_nolen(sv);
1987         PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
1988         DEBUG_x(dump_all());
1989 #else
1990         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
1991 #endif
1992         break;
1993     case '\005':  /* ^E */
1994         if (*(mg->mg_ptr+1) == '\0') {
1995 #ifdef MACOS_TRADITIONAL
1996             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1997 #else
1998 #  ifdef VMS
1999             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2000 #  else
2001 #    ifdef WIN32
2002             SetLastError( SvIV(sv) );
2003 #    else
2004 #      ifdef OS2
2005             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2006 #      else
2007             /* will anyone ever use this? */
2008             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2009 #      endif
2010 #    endif
2011 #  endif
2012 #endif
2013         }
2014         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2015             if (PL_encoding)
2016                 SvREFCNT_dec(PL_encoding);
2017             if (SvOK(sv) || SvGMAGICAL(sv)) {
2018                 PL_encoding = newSVsv(sv);
2019             }
2020             else {
2021                 PL_encoding = Nullsv;
2022             }
2023         }
2024         break;
2025     case '\006':        /* ^F */
2026         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2027         break;
2028     case '\010':        /* ^H */
2029         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2030         break;
2031     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2032         if (PL_inplace)
2033             Safefree(PL_inplace);
2034         if (SvOK(sv))
2035             PL_inplace = savepv(SvPV(sv,len));
2036         else
2037             PL_inplace = Nullch;
2038         break;
2039     case '\017':        /* ^O */
2040         if (*(mg->mg_ptr+1) == '\0') {
2041             if (PL_osname)
2042                 Safefree(PL_osname);
2043             if (SvOK(sv))
2044                 PL_osname = savepv(SvPV(sv,len));
2045             else
2046                 PL_osname = Nullch;
2047         }
2048         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2049             if (!PL_compiling.cop_io)
2050                 PL_compiling.cop_io = newSVsv(sv);
2051             else
2052                 sv_setsv(PL_compiling.cop_io,sv);
2053         }
2054         break;
2055     case '\020':        /* ^P */
2056         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2057         if (PL_perldb && !PL_DBsingle)
2058             init_debugger();
2059         break;
2060     case '\024':        /* ^T */
2061 #ifdef BIG_TIME
2062         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2063 #else
2064         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2065 #endif
2066         break;
2067     case '\027':        /* ^W & $^WARNING_BITS */
2068         if (*(mg->mg_ptr+1) == '\0') {
2069             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2070                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2071                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2072                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2073             }
2074         }
2075         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2076             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2077                 if (!SvPOK(sv) && PL_localizing) {
2078                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2079                     PL_compiling.cop_warnings = pWARN_NONE;
2080                     break;
2081                 }
2082                 {
2083                     STRLEN len, i;
2084                     int accumulate = 0 ;
2085                     int any_fatals = 0 ;
2086                     char * ptr = (char*)SvPV(sv, len) ;
2087                     for (i = 0 ; i < len ; ++i) {
2088                         accumulate |= ptr[i] ;
2089                         any_fatals |= (ptr[i] & 0xAA) ;
2090                     }
2091                     if (!accumulate)
2092                         PL_compiling.cop_warnings = pWARN_NONE;
2093                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2094                         PL_compiling.cop_warnings = pWARN_ALL;
2095                         PL_dowarn |= G_WARN_ONCE ;
2096                     }
2097                     else {
2098                         if (specialWARN(PL_compiling.cop_warnings))
2099                             PL_compiling.cop_warnings = newSVsv(sv) ;
2100                         else
2101                             sv_setsv(PL_compiling.cop_warnings, sv);
2102                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2103                             PL_dowarn |= G_WARN_ONCE ;
2104                     }
2105
2106                 }
2107             }
2108         }
2109         break;
2110     case '.':
2111         if (PL_localizing) {
2112             if (PL_localizing == 1)
2113                 SAVESPTR(PL_last_in_gv);
2114         }
2115         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2116             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2117         break;
2118     case '^':
2119         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2120         IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2121         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2122         break;
2123     case '~':
2124         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2125         IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
2126         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
2127         break;
2128     case '=':
2129         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2130         break;
2131     case '-':
2132         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2133         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2134             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2135         break;
2136     case '%':
2137         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2138         break;
2139     case '|':
2140         {
2141             IO *io = GvIOp(PL_defoutgv);
2142             if(!io)
2143               break;
2144             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2145                 IoFLAGS(io) &= ~IOf_FLUSH;
2146             else {
2147                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2148                     PerlIO *ofp = IoOFP(io);
2149                     if (ofp)
2150                         (void)PerlIO_flush(ofp);
2151                     IoFLAGS(io) |= IOf_FLUSH;
2152                 }
2153             }
2154         }
2155         break;
2156     case '/':
2157         SvREFCNT_dec(PL_rs);
2158         PL_rs = newSVsv(sv);
2159         break;
2160     case '\\':
2161         if (PL_ors_sv)
2162             SvREFCNT_dec(PL_ors_sv);
2163         if (SvOK(sv) || SvGMAGICAL(sv)) {
2164             PL_ors_sv = newSVsv(sv);
2165         }
2166         else {
2167             PL_ors_sv = Nullsv;
2168         }
2169         break;
2170     case ',':
2171         if (PL_ofs_sv)
2172             SvREFCNT_dec(PL_ofs_sv);
2173         if (SvOK(sv) || SvGMAGICAL(sv)) {
2174             PL_ofs_sv = newSVsv(sv);
2175         }
2176         else {
2177             PL_ofs_sv = Nullsv;
2178         }
2179         break;
2180     case '#':
2181         if (PL_ofmt)
2182             Safefree(PL_ofmt);
2183         PL_ofmt = savepv(SvPV(sv,len));
2184         break;
2185     case '[':
2186         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2187         break;
2188     case '?':
2189 #ifdef COMPLEX_STATUS
2190         if (PL_localizing == 2) {
2191             PL_statusvalue = LvTARGOFF(sv);
2192             PL_statusvalue_vms = LvTARGLEN(sv);
2193         }
2194         else
2195 #endif
2196 #ifdef VMSISH_STATUS
2197         if (VMSISH_STATUS)
2198             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2199         else
2200 #endif
2201             STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2202         break;
2203     case '!':
2204         {
2205 #ifdef VMS
2206 #   define PERL_VMS_BANG vaxc$errno
2207 #else
2208 #   define PERL_VMS_BANG 0
2209 #endif
2210         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2211                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2212         }
2213         break;
2214     case '<':
2215         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2216         if (PL_delaymagic) {
2217             PL_delaymagic |= DM_RUID;
2218             break;                              /* don't do magic till later */
2219         }
2220 #ifdef HAS_SETRUID
2221         (void)setruid((Uid_t)PL_uid);
2222 #else
2223 #ifdef HAS_SETREUID
2224         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2225 #else
2226 #ifdef HAS_SETRESUID
2227       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2228 #else
2229         if (PL_uid == PL_euid)          /* special case $< = $> */
2230             (void)PerlProc_setuid(PL_uid);
2231         else {
2232             PL_uid = PerlProc_getuid();
2233             Perl_croak(aTHX_ "setruid() not implemented");
2234         }
2235 #endif
2236 #endif
2237 #endif
2238         PL_uid = PerlProc_getuid();
2239         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2240         break;
2241     case '>':
2242         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2243         if (PL_delaymagic) {
2244             PL_delaymagic |= DM_EUID;
2245             break;                              /* don't do magic till later */
2246         }
2247 #ifdef HAS_SETEUID
2248         (void)seteuid((Uid_t)PL_euid);
2249 #else
2250 #ifdef HAS_SETREUID
2251         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2252 #else
2253 #ifdef HAS_SETRESUID
2254         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2255 #else
2256         if (PL_euid == PL_uid)          /* special case $> = $< */
2257             PerlProc_setuid(PL_euid);
2258         else {
2259             PL_euid = PerlProc_geteuid();
2260             Perl_croak(aTHX_ "seteuid() not implemented");
2261         }
2262 #endif
2263 #endif
2264 #endif
2265         PL_euid = PerlProc_geteuid();
2266         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2267         break;
2268     case '(':
2269         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2270         if (PL_delaymagic) {
2271             PL_delaymagic |= DM_RGID;
2272             break;                              /* don't do magic till later */
2273         }
2274 #ifdef HAS_SETRGID
2275         (void)setrgid((Gid_t)PL_gid);
2276 #else
2277 #ifdef HAS_SETREGID
2278         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2279 #else
2280 #ifdef HAS_SETRESGID
2281       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2282 #else
2283         if (PL_gid == PL_egid)                  /* special case $( = $) */
2284             (void)PerlProc_setgid(PL_gid);
2285         else {
2286             PL_gid = PerlProc_getgid();
2287             Perl_croak(aTHX_ "setrgid() not implemented");
2288         }
2289 #endif
2290 #endif
2291 #endif
2292         PL_gid = PerlProc_getgid();
2293         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2294         break;
2295     case ')':
2296 #ifdef HAS_SETGROUPS
2297         {
2298             char *p = SvPV(sv, len);
2299             Groups_t gary[NGROUPS];
2300
2301             while (isSPACE(*p))
2302                 ++p;
2303             PL_egid = Atol(p);
2304             for (i = 0; i < NGROUPS; ++i) {
2305                 while (*p && !isSPACE(*p))
2306                     ++p;
2307                 while (isSPACE(*p))
2308                     ++p;
2309                 if (!*p)
2310                     break;
2311                 gary[i] = Atol(p);
2312             }
2313             if (i)
2314                 (void)setgroups(i, gary);
2315         }
2316 #else  /* HAS_SETGROUPS */
2317         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2318 #endif /* HAS_SETGROUPS */
2319         if (PL_delaymagic) {
2320             PL_delaymagic |= DM_EGID;
2321             break;                              /* don't do magic till later */
2322         }
2323 #ifdef HAS_SETEGID
2324         (void)setegid((Gid_t)PL_egid);
2325 #else
2326 #ifdef HAS_SETREGID
2327         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2328 #else
2329 #ifdef HAS_SETRESGID
2330         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2331 #else
2332         if (PL_egid == PL_gid)                  /* special case $) = $( */
2333             (void)PerlProc_setgid(PL_egid);
2334         else {
2335             PL_egid = PerlProc_getegid();
2336             Perl_croak(aTHX_ "setegid() not implemented");
2337         }
2338 #endif
2339 #endif
2340 #endif
2341         PL_egid = PerlProc_getegid();
2342         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2343         break;
2344     case ':':
2345         PL_chopset = SvPV_force(sv,len);
2346         break;
2347 #ifndef MACOS_TRADITIONAL
2348     case '0':
2349         LOCK_DOLLARZERO_MUTEX;
2350 #ifdef HAS_SETPROCTITLE
2351         /* The BSDs don't show the argv[] in ps(1) output, they
2352          * show a string from the process struct and provide
2353          * the setproctitle() routine to manipulate that. */
2354         {
2355             s = SvPV(sv, len);
2356 #   if __FreeBSD_version > 410001
2357             /* The leading "-" removes the "perl: " prefix,
2358              * but not the "(perl) suffix from the ps(1)
2359              * output, because that's what ps(1) shows if the
2360              * argv[] is modified. */
2361             setproctitle("-%s", s);
2362 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2363             /* This doesn't really work if you assume that
2364              * $0 = 'foobar'; will wipe out 'perl' from the $0
2365              * because in ps(1) output the result will be like
2366              * sprintf("perl: %s (perl)", s)
2367              * I guess this is a security feature:
2368              * one (a user process) cannot get rid of the original name.
2369              * --jhi */
2370             setproctitle("%s", s);
2371 #   endif
2372         }
2373 #endif
2374 #if defined(__hpux) && defined(PSTAT_SETCMD)
2375         {
2376              union pstun un;
2377              s = SvPV(sv, len);
2378              un.pst_command = s;
2379              pstat(PSTAT_SETCMD, un, len, 0, 0);
2380         }
2381 #endif
2382         /* PL_origalen is set in perl_parse(). */
2383         s = SvPV_force(sv,len);
2384         if (len >= (STRLEN)PL_origalen) {
2385             /* Longer than original, will be truncated. */
2386             Copy(s, PL_origargv[0], PL_origalen, char);
2387             PL_origargv[0][PL_origalen - 1] = 0;
2388         }
2389         else {
2390             /* Shorter than original, will be padded. */
2391             Copy(s, PL_origargv[0], len, char);
2392             PL_origargv[0][len] = 0;
2393             memset(PL_origargv[0] + len + 1,
2394                    /* Is the space counterintuitive?  Yes.
2395                     * (You were expecting \0?)
2396                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2397                     * --jhi */
2398                    (int)' ',
2399                    PL_origalen - len - 1);
2400             for (i = 1; i < PL_origargc; i++)
2401                  PL_origargv[i] = 0;
2402         }
2403         UNLOCK_DOLLARZERO_MUTEX;
2404         break;
2405 #endif
2406     }
2407     return 0;
2408 }
2409
2410 I32
2411 Perl_whichsig(pTHX_ char *sig)
2412 {
2413     register char **sigv;
2414
2415     for (sigv = PL_sig_name; *sigv; sigv++)
2416         if (strEQ(sig,*sigv))
2417             return PL_sig_num[sigv - PL_sig_name];
2418 #ifdef SIGCLD
2419     if (strEQ(sig,"CHLD"))
2420         return SIGCLD;
2421 #endif
2422 #ifdef SIGCHLD
2423     if (strEQ(sig,"CLD"))
2424         return SIGCHLD;
2425 #endif
2426     return -1;
2427 }
2428
2429 #if !defined(PERL_IMPLICIT_CONTEXT)
2430 static SV* sig_sv;
2431 #endif
2432
2433 Signal_t
2434 Perl_sighandler(int sig)
2435 {
2436 #ifdef PERL_GET_SIG_CONTEXT
2437     dTHXa(PERL_GET_SIG_CONTEXT);
2438 #else
2439     dTHX;
2440 #endif
2441     dSP;
2442     GV *gv = Nullgv;
2443     HV *st;
2444     SV *sv = Nullsv, *tSv = PL_Sv;
2445     CV *cv = Nullcv;
2446     OP *myop = PL_op;
2447     U32 flags = 0;
2448     XPV *tXpv = PL_Xpv;
2449
2450     if (PL_savestack_ix + 15 <= PL_savestack_max)
2451         flags |= 1;
2452     if (PL_markstack_ptr < PL_markstack_max - 2)
2453         flags |= 4;
2454     if (PL_retstack_ix < PL_retstack_max - 2)
2455         flags |= 8;
2456     if (PL_scopestack_ix < PL_scopestack_max - 3)
2457         flags |= 16;
2458
2459     if (!PL_psig_ptr[sig]) {
2460                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2461                                  PL_sig_name[sig]);
2462                 exit(sig);
2463         }
2464
2465     /* Max number of items pushed there is 3*n or 4. We cannot fix
2466        infinity, so we fix 4 (in fact 5): */
2467     if (flags & 1) {
2468         PL_savestack_ix += 5;           /* Protect save in progress. */
2469         SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2470     }
2471     if (flags & 4)
2472         PL_markstack_ptr++;             /* Protect mark. */
2473     if (flags & 8) {
2474         PL_retstack_ix++;
2475         PL_retstack[PL_retstack_ix] = NULL;
2476     }
2477     if (flags & 16)
2478         PL_scopestack_ix += 1;
2479     /* sv_2cv is too complicated, try a simpler variant first: */
2480     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2481         || SvTYPE(cv) != SVt_PVCV)
2482         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2483
2484     if (!cv || !CvROOT(cv)) {
2485         if (ckWARN(WARN_SIGNAL))
2486             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2487                 PL_sig_name[sig], (gv ? GvENAME(gv)
2488                                 : ((cv && CvGV(cv))
2489                                    ? GvENAME(CvGV(cv))
2490                                    : "__ANON__")));
2491         goto cleanup;
2492     }
2493
2494     if(PL_psig_name[sig]) {
2495         sv = SvREFCNT_inc(PL_psig_name[sig]);
2496         flags |= 64;
2497 #if !defined(PERL_IMPLICIT_CONTEXT)
2498         sig_sv = sv;
2499 #endif
2500     } else {
2501         sv = sv_newmortal();
2502         sv_setpv(sv,PL_sig_name[sig]);
2503     }
2504
2505     PUSHSTACKi(PERLSI_SIGNAL);
2506     PUSHMARK(SP);
2507     PUSHs(sv);
2508     PUTBACK;
2509
2510     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2511
2512     POPSTACK;
2513     if (SvTRUE(ERRSV)) {
2514 #ifndef PERL_MICRO
2515 #ifdef HAS_SIGPROCMASK
2516         /* Handler "died", for example to get out of a restart-able read().
2517          * Before we re-do that on its behalf re-enable the signal which was
2518          * blocked by the system when we entered.
2519          */
2520         sigset_t set;
2521         sigemptyset(&set);
2522         sigaddset(&set,sig);
2523         sigprocmask(SIG_UNBLOCK, &set, NULL);
2524 #else
2525         /* Not clear if this will work */
2526         (void)rsignal(sig, SIG_IGN);
2527         (void)rsignal(sig, PL_csighandlerp);
2528 #endif
2529 #endif /* !PERL_MICRO */
2530         Perl_die(aTHX_ Nullformat);
2531     }
2532 cleanup:
2533     if (flags & 1)
2534         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2535     if (flags & 4)
2536         PL_markstack_ptr--;
2537     if (flags & 8)
2538         PL_retstack_ix--;
2539     if (flags & 16)
2540         PL_scopestack_ix -= 1;
2541     if (flags & 64)
2542         SvREFCNT_dec(sv);
2543     PL_op = myop;                       /* Apparently not needed... */
2544
2545     PL_Sv = tSv;                        /* Restore global temporaries. */
2546     PL_Xpv = tXpv;
2547     return;
2548 }
2549
2550
2551 static void
2552 restore_magic(pTHX_ void *p)
2553 {
2554     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2555     SV* sv = mgs->mgs_sv;
2556
2557     if (!sv)
2558         return;
2559
2560     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2561     {
2562         if (mgs->mgs_flags)
2563             SvFLAGS(sv) |= mgs->mgs_flags;
2564         else
2565             mg_magical(sv);
2566         if (SvGMAGICAL(sv))
2567             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2568     }
2569
2570     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2571
2572     /* If we're still on top of the stack, pop us off.  (That condition
2573      * will be satisfied if restore_magic was called explicitly, but *not*
2574      * if it's being called via leave_scope.)
2575      * The reason for doing this is that otherwise, things like sv_2cv()
2576      * may leave alloc gunk on the savestack, and some code
2577      * (e.g. sighandler) doesn't expect that...
2578      */
2579     if (PL_savestack_ix == mgs->mgs_ss_ix)
2580     {
2581         I32 popval = SSPOPINT;
2582         assert(popval == SAVEt_DESTRUCTOR_X);
2583         PL_savestack_ix -= 2;
2584         popval = SSPOPINT;
2585         assert(popval == SAVEt_ALLOC);
2586         popval = SSPOPINT;
2587         PL_savestack_ix -= popval;
2588     }
2589
2590 }
2591
2592 static void
2593 unwind_handler_stack(pTHX_ void *p)
2594 {
2595     U32 flags = *(U32*)p;
2596
2597     if (flags & 1)
2598         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2599     /* cxstack_ix-- Not needed, die already unwound it. */
2600 #if !defined(PERL_IMPLICIT_CONTEXT)
2601     if (flags & 64)
2602         SvREFCNT_dec(sig_sv);
2603 #endif
2604 }
2605
2606