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