mg.c

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