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