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