mg.c

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