mg.c

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