mg.c

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