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     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1677
1678     if (mg) {
1679         /* arylen scalar holds a pointer back to the array, but doesn't own a
1680            reference. Hence the we (the array) are about to go away with it
1681            still pointing at us. Clear its pointer, else it would be pointing
1682            at free memory. See the comment in sv_magic about reference loops,
1683            and why it can't own a reference to us.  */
1684         mg->mg_obj = 0;
1685     }
1686     return 0;
1687 }
1688
1689 int
1690 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1691 {
1692     SV* lsv = LvTARG(sv);
1693
1694     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1695         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1696         if (mg && mg->mg_len >= 0) {
1697             I32 i = mg->mg_len;
1698             if (DO_UTF8(lsv))
1699                 sv_pos_b2u(lsv, &i);
1700             sv_setiv(sv, i + PL_curcop->cop_arybase);
1701             return 0;
1702         }
1703     }
1704     SvOK_off(sv);
1705     return 0;
1706 }
1707
1708 int
1709 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1710 {
1711     SV* lsv = LvTARG(sv);
1712     SSize_t pos;
1713     STRLEN len;
1714     STRLEN ulen = 0;
1715
1716     mg = 0;
1717
1718     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1719         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1720     if (!mg) {
1721         if (!SvOK(sv))
1722             return 0;
1723         sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1724         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1725     }
1726     else if (!SvOK(sv)) {
1727         mg->mg_len = -1;
1728         return 0;
1729     }
1730     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1731
1732     pos = SvIV(sv) - PL_curcop->cop_arybase;
1733
1734     if (DO_UTF8(lsv)) {
1735         ulen = sv_len_utf8(lsv);
1736         if (ulen)
1737             len = ulen;
1738     }
1739
1740     if (pos < 0) {
1741         pos += len;
1742         if (pos < 0)
1743             pos = 0;
1744     }
1745     else if (pos > (SSize_t)len)
1746         pos = len;
1747
1748     if (ulen) {
1749         I32 p = pos;
1750         sv_pos_u2b(lsv, &p, 0);
1751         pos = p;
1752     }
1753
1754     mg->mg_len = pos;
1755     mg->mg_flags &= ~MGf_MINMATCH;
1756
1757     return 0;
1758 }
1759
1760 int
1761 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1762 {
1763     (void)mg;
1764     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1765         SvFAKE_off(sv);
1766         gv_efullname3(sv,((GV*)sv), "*");
1767         SvFAKE_on(sv);
1768     }
1769     else
1770         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1771     return 0;
1772 }
1773
1774 int
1775 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1776 {
1777     GV* gv;
1778     (void)mg;
1779
1780     if (!SvOK(sv))
1781         return 0;
1782     gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1783     if (sv == (SV*)gv)
1784         return 0;
1785     if (GvGP(sv))
1786         gp_free((GV*)sv);
1787     GvGP(sv) = gp_ref(GvGP(gv));
1788     return 0;
1789 }
1790
1791 int
1792 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1793 {
1794     STRLEN len;
1795     SV * const lsv = LvTARG(sv);
1796     const char * const tmps = SvPV_const(lsv,len);
1797     I32 offs = LvTARGOFF(sv);
1798     I32 rem = LvTARGLEN(sv);
1799     (void)mg;
1800
1801     if (SvUTF8(lsv))
1802         sv_pos_u2b(lsv, &offs, &rem);
1803     if (offs > (I32)len)
1804         offs = len;
1805     if (rem + offs > (I32)len)
1806         rem = len - offs;
1807     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1808     if (SvUTF8(lsv))
1809         SvUTF8_on(sv);
1810     return 0;
1811 }
1812
1813 int
1814 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1815 {
1816     STRLEN len;
1817     const char *tmps = SvPV_const(sv, len);
1818     SV * const lsv = LvTARG(sv);
1819     I32 lvoff = LvTARGOFF(sv);
1820     I32 lvlen = LvTARGLEN(sv);
1821     (void)mg;
1822
1823     if (DO_UTF8(sv)) {
1824         sv_utf8_upgrade(lsv);
1825         sv_pos_u2b(lsv, &lvoff, &lvlen);
1826         sv_insert(lsv, lvoff, lvlen, tmps, len);
1827         LvTARGLEN(sv) = sv_len_utf8(sv);
1828         SvUTF8_on(lsv);
1829     }
1830     else if (lsv && SvUTF8(lsv)) {
1831         sv_pos_u2b(lsv, &lvoff, &lvlen);
1832         LvTARGLEN(sv) = len;
1833         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1834         sv_insert(lsv, lvoff, lvlen, tmps, len);
1835         Safefree(tmps);
1836     }
1837     else {
1838         sv_insert(lsv, lvoff, lvlen, tmps, len);
1839         LvTARGLEN(sv) = len;
1840     }
1841
1842
1843     return 0;
1844 }
1845
1846 int
1847 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1848 {
1849     TAINT_IF((mg->mg_len & 1) ||
1850              ((mg->mg_len & 2) && mg->mg_obj == sv));   /* kludge */
1851     return 0;
1852 }
1853
1854 int
1855 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1856 {
1857     (void)sv;
1858     if (PL_localizing) {
1859         if (PL_localizing == 1)
1860             mg->mg_len <<= 1;
1861         else
1862             mg->mg_len >>= 1;
1863     }
1864     else if (PL_tainted)
1865         mg->mg_len |= 1;
1866     else
1867         mg->mg_len &= ~1;
1868     return 0;
1869 }
1870
1871 int
1872 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1873 {
1874     SV * const lsv = LvTARG(sv);
1875     (void)mg;
1876
1877     if (!lsv) {
1878         SvOK_off(sv);
1879         return 0;
1880     }
1881
1882     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1883     return 0;
1884 }
1885
1886 int
1887 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1888 {
1889     (void)mg;
1890     do_vecset(sv);      /* XXX slurp this routine */
1891     return 0;
1892 }
1893
1894 int
1895 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1896 {
1897     SV *targ = Nullsv;
1898     if (LvTARGLEN(sv)) {
1899         if (mg->mg_obj) {
1900             SV *ahv = LvTARG(sv);
1901             HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1902             if (he)
1903                 targ = HeVAL(he);
1904         }
1905         else {
1906             AV* av = (AV*)LvTARG(sv);
1907             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1908                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1909         }
1910         if (targ && targ != &PL_sv_undef) {
1911             /* somebody else defined it for us */
1912             SvREFCNT_dec(LvTARG(sv));
1913             LvTARG(sv) = SvREFCNT_inc(targ);
1914             LvTARGLEN(sv) = 0;
1915             SvREFCNT_dec(mg->mg_obj);
1916             mg->mg_obj = Nullsv;
1917             mg->mg_flags &= ~MGf_REFCOUNTED;
1918         }
1919     }
1920     else
1921         targ = LvTARG(sv);
1922     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1923     return 0;
1924 }
1925
1926 int
1927 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1928 {
1929     (void)mg;
1930     if (LvTARGLEN(sv))
1931         vivify_defelem(sv);
1932     if (LvTARG(sv)) {
1933         sv_setsv(LvTARG(sv), sv);
1934         SvSETMAGIC(LvTARG(sv));
1935     }
1936     return 0;
1937 }
1938
1939 void
1940 Perl_vivify_defelem(pTHX_ SV *sv)
1941 {
1942     MAGIC *mg;
1943     SV *value = Nullsv;
1944
1945     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1946         return;
1947     if (mg->mg_obj) {
1948         SV *ahv = LvTARG(sv);
1949         HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1950         if (he)
1951             value = HeVAL(he);
1952         if (!value || value == &PL_sv_undef)
1953             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
1954     }
1955     else {
1956         AV* av = (AV*)LvTARG(sv);
1957         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1958             LvTARG(sv) = Nullsv;        /* array can't be extended */
1959         else {
1960             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1961             if (!svp || (value = *svp) == &PL_sv_undef)
1962                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1963         }
1964     }
1965     (void)SvREFCNT_inc(value);
1966     SvREFCNT_dec(LvTARG(sv));
1967     LvTARG(sv) = value;
1968     LvTARGLEN(sv) = 0;
1969     SvREFCNT_dec(mg->mg_obj);
1970     mg->mg_obj = Nullsv;
1971     mg->mg_flags &= ~MGf_REFCOUNTED;
1972 }
1973
1974 int
1975 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1976 {
1977     AV *av = (AV*)mg->mg_obj;
1978     SV **svp = AvARRAY(av);
1979     I32 i = AvFILLp(av);
1980     (void)sv;
1981
1982     while (i >= 0) {
1983         if (svp[i]) {
1984             if (!SvWEAKREF(svp[i]))
1985                 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1986             /* XXX Should we check that it hasn't changed? */
1987             SvRV_set(svp[i], 0);
1988             SvOK_off(svp[i]);
1989             SvWEAKREF_off(svp[i]);
1990             svp[i] = Nullsv;
1991         }
1992         i--;
1993     }
1994     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1995     return 0;
1996 }
1997
1998 int
1999 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2000 {
2001     mg->mg_len = -1;
2002     SvSCREAM_off(sv);
2003     return 0;
2004 }
2005
2006 int
2007 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2008 {
2009     (void)mg;
2010     sv_unmagic(sv, PERL_MAGIC_bm);
2011     SvVALID_off(sv);
2012     return 0;
2013 }
2014
2015 int
2016 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2017 {
2018     (void)mg;
2019     sv_unmagic(sv, PERL_MAGIC_fm);
2020     SvCOMPILED_off(sv);
2021     return 0;
2022 }
2023
2024 int
2025 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2026 {
2027     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2028
2029     if (uf && uf->uf_set)
2030         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2031     return 0;
2032 }
2033
2034 int
2035 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2036 {
2037     (void)mg;
2038     sv_unmagic(sv, PERL_MAGIC_qr);
2039     return 0;
2040 }
2041
2042 int
2043 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2044 {
2045     regexp *re = (regexp *)mg->mg_obj;
2046     ReREFCNT_dec(re);
2047     (void)sv;
2048     return 0;
2049 }
2050
2051 #ifdef USE_LOCALE_COLLATE
2052 int
2053 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2054 {
2055     /*
2056      * RenE<eacute> Descartes said "I think not."
2057      * and vanished with a faint plop.
2058      */
2059     (void)sv;
2060     if (mg->mg_ptr) {
2061         Safefree(mg->mg_ptr);
2062         mg->mg_ptr = NULL;
2063         mg->mg_len = -1;
2064     }
2065     return 0;
2066 }
2067 #endif /* USE_LOCALE_COLLATE */
2068
2069 /* Just clear the UTF-8 cache data. */
2070 int
2071 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2072 {
2073     (void)sv;
2074     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2075     mg->mg_ptr = 0;
2076     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2077     return 0;
2078 }
2079
2080 int
2081 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2082 {
2083     register const char *s;
2084     I32 i;
2085     STRLEN len;
2086     switch (*mg->mg_ptr) {
2087     case '\001':        /* ^A */
2088         sv_setsv(PL_bodytarget, sv);
2089         break;
2090     case '\003':        /* ^C */
2091         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2092         break;
2093
2094     case '\004':        /* ^D */
2095 #ifdef DEBUGGING
2096         s = SvPV_nolen_const(sv);
2097         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2098         DEBUG_x(dump_all());
2099 #else
2100         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2101 #endif
2102         break;
2103     case '\005':  /* ^E */
2104         if (*(mg->mg_ptr+1) == '\0') {
2105 #ifdef MACOS_TRADITIONAL
2106             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2107 #else
2108 #  ifdef VMS
2109             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2110 #  else
2111 #    ifdef WIN32
2112             SetLastError( SvIV(sv) );
2113 #    else
2114 #      ifdef OS2
2115             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2116 #      else
2117             /* will anyone ever use this? */
2118             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2119 #      endif
2120 #    endif
2121 #  endif
2122 #endif
2123         }
2124         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2125             if (PL_encoding)
2126                 SvREFCNT_dec(PL_encoding);
2127             if (SvOK(sv) || SvGMAGICAL(sv)) {
2128                 PL_encoding = newSVsv(sv);
2129             }
2130             else {
2131                 PL_encoding = Nullsv;
2132             }
2133         }
2134         break;
2135     case '\006':        /* ^F */
2136         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2137         break;
2138     case '\010':        /* ^H */
2139         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2140         break;
2141     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2142         if (PL_inplace)
2143             Safefree(PL_inplace);
2144         if (SvOK(sv))
2145             PL_inplace = savesvpv(sv);
2146         else
2147             PL_inplace = Nullch;
2148         break;
2149     case '\017':        /* ^O */
2150         if (*(mg->mg_ptr+1) == '\0') {
2151             if (PL_osname) {
2152                 Safefree(PL_osname);
2153                 PL_osname = Nullch;
2154             }
2155             if (SvOK(sv)) {
2156                 TAINT_PROPER("assigning to $^O");
2157                 PL_osname = savesvpv(sv);
2158             }
2159         }
2160         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2161             if (!PL_compiling.cop_io)
2162                 PL_compiling.cop_io = newSVsv(sv);
2163             else
2164                 sv_setsv(PL_compiling.cop_io,sv);
2165         }
2166         break;
2167     case '\020':        /* ^P */
2168         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2169         if (PL_perldb && !PL_DBsingle)
2170             init_debugger();
2171         break;
2172     case '\024':        /* ^T */
2173 #ifdef BIG_TIME
2174         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2175 #else
2176         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2177 #endif
2178         break;
2179     case '\027':        /* ^W & $^WARNING_BITS */
2180         if (*(mg->mg_ptr+1) == '\0') {
2181             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2182                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2183                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2184                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2185             }
2186         }
2187         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2188             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2189                 if (!SvPOK(sv) && PL_localizing) {
2190                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2191                     PL_compiling.cop_warnings = pWARN_NONE;
2192                     break;
2193                 }
2194                 {
2195                     STRLEN len, i;
2196                     int accumulate = 0 ;
2197                     int any_fatals = 0 ;
2198                     const char * const ptr = SvPV_const(sv, len) ;
2199                     for (i = 0 ; i < len ; ++i) {
2200                         accumulate |= ptr[i] ;
2201                         any_fatals |= (ptr[i] & 0xAA) ;
2202                     }
2203                     if (!accumulate)
2204                         PL_compiling.cop_warnings = pWARN_NONE;
2205                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2206                         PL_compiling.cop_warnings = pWARN_ALL;
2207                         PL_dowarn |= G_WARN_ONCE ;
2208                     }
2209                     else {
2210                         if (specialWARN(PL_compiling.cop_warnings))
2211                             PL_compiling.cop_warnings = newSVsv(sv) ;
2212                         else
2213                             sv_setsv(PL_compiling.cop_warnings, sv);
2214                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2215                             PL_dowarn |= G_WARN_ONCE ;
2216                     }
2217
2218                 }
2219             }
2220         }
2221         break;
2222     case '.':
2223         if (PL_localizing) {
2224             if (PL_localizing == 1)
2225                 SAVESPTR(PL_last_in_gv);
2226         }
2227         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2228             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2229         break;
2230     case '^':
2231         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2232         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2233         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2234         break;
2235     case '~':
2236         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2237         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2238         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2239         break;
2240     case '=':
2241         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2242         break;
2243     case '-':
2244         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2245         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2246             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2247         break;
2248     case '%':
2249         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2250         break;
2251     case '|':
2252         {
2253             IO *io = GvIOp(PL_defoutgv);
2254             if(!io)
2255               break;
2256             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2257                 IoFLAGS(io) &= ~IOf_FLUSH;
2258             else {
2259                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2260                     PerlIO *ofp = IoOFP(io);
2261                     if (ofp)
2262                         (void)PerlIO_flush(ofp);
2263                     IoFLAGS(io) |= IOf_FLUSH;
2264                 }
2265             }
2266         }
2267         break;
2268     case '/':
2269         SvREFCNT_dec(PL_rs);
2270         PL_rs = newSVsv(sv);
2271         break;
2272     case '\\':
2273         if (PL_ors_sv)
2274             SvREFCNT_dec(PL_ors_sv);
2275         if (SvOK(sv) || SvGMAGICAL(sv)) {
2276             PL_ors_sv = newSVsv(sv);
2277         }
2278         else {
2279             PL_ors_sv = Nullsv;
2280         }
2281         break;
2282     case ',':
2283         if (PL_ofs_sv)
2284             SvREFCNT_dec(PL_ofs_sv);
2285         if (SvOK(sv) || SvGMAGICAL(sv)) {
2286             PL_ofs_sv = newSVsv(sv);
2287         }
2288         else {
2289             PL_ofs_sv = Nullsv;
2290         }
2291         break;
2292     case '#':
2293         if (PL_ofmt)
2294             Safefree(PL_ofmt);
2295         PL_ofmt = savesvpv(sv);
2296         break;
2297     case '[':
2298         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2299         break;
2300     case '?':
2301 #ifdef COMPLEX_STATUS
2302         if (PL_localizing == 2) {
2303             PL_statusvalue = LvTARGOFF(sv);
2304             PL_statusvalue_vms = LvTARGLEN(sv);
2305         }
2306         else
2307 #endif
2308 #ifdef VMSISH_STATUS
2309         if (VMSISH_STATUS)
2310             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2311         else
2312 #endif
2313             STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2314         break;
2315     case '!':
2316         {
2317 #ifdef VMS
2318 #   define PERL_VMS_BANG vaxc$errno
2319 #else
2320 #   define PERL_VMS_BANG 0
2321 #endif
2322         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2323                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2324         }
2325         break;
2326     case '<':
2327         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2328         if (PL_delaymagic) {
2329             PL_delaymagic |= DM_RUID;
2330             break;                              /* don't do magic till later */
2331         }
2332 #ifdef HAS_SETRUID
2333         (void)setruid((Uid_t)PL_uid);
2334 #else
2335 #ifdef HAS_SETREUID
2336         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2337 #else
2338 #ifdef HAS_SETRESUID
2339       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2340 #else
2341         if (PL_uid == PL_euid) {                /* special case $< = $> */
2342 #ifdef PERL_DARWIN
2343             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2344             if (PL_uid != 0 && PerlProc_getuid() == 0)
2345                 (void)PerlProc_setuid(0);
2346 #endif
2347             (void)PerlProc_setuid(PL_uid);
2348         } else {
2349             PL_uid = PerlProc_getuid();
2350             Perl_croak(aTHX_ "setruid() not implemented");
2351         }
2352 #endif
2353 #endif
2354 #endif
2355         PL_uid = PerlProc_getuid();
2356         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2357         break;
2358     case '>':
2359         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2360         if (PL_delaymagic) {
2361             PL_delaymagic |= DM_EUID;
2362             break;                              /* don't do magic till later */
2363         }
2364 #ifdef HAS_SETEUID
2365         (void)seteuid((Uid_t)PL_euid);
2366 #else
2367 #ifdef HAS_SETREUID
2368         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2369 #else
2370 #ifdef HAS_SETRESUID
2371         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2372 #else
2373         if (PL_euid == PL_uid)          /* special case $> = $< */
2374             PerlProc_setuid(PL_euid);
2375         else {
2376             PL_euid = PerlProc_geteuid();
2377             Perl_croak(aTHX_ "seteuid() not implemented");
2378         }
2379 #endif
2380 #endif
2381 #endif
2382         PL_euid = PerlProc_geteuid();
2383         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2384         break;
2385     case '(':
2386         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2387         if (PL_delaymagic) {
2388             PL_delaymagic |= DM_RGID;
2389             break;                              /* don't do magic till later */
2390         }
2391 #ifdef HAS_SETRGID
2392         (void)setrgid((Gid_t)PL_gid);
2393 #else
2394 #ifdef HAS_SETREGID
2395         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2396 #else
2397 #ifdef HAS_SETRESGID
2398       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2399 #else
2400         if (PL_gid == PL_egid)                  /* special case $( = $) */
2401             (void)PerlProc_setgid(PL_gid);
2402         else {
2403             PL_gid = PerlProc_getgid();
2404             Perl_croak(aTHX_ "setrgid() not implemented");
2405         }
2406 #endif
2407 #endif
2408 #endif
2409         PL_gid = PerlProc_getgid();
2410         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2411         break;
2412     case ')':
2413 #ifdef HAS_SETGROUPS
2414         {
2415             const char *p = SvPV_const(sv, len);
2416             Groups_t gary[NGROUPS];
2417
2418             while (isSPACE(*p))
2419                 ++p;
2420             PL_egid = Atol(p);
2421             for (i = 0; i < NGROUPS; ++i) {
2422                 while (*p && !isSPACE(*p))
2423                     ++p;
2424                 while (isSPACE(*p))
2425                     ++p;
2426                 if (!*p)
2427                     break;
2428                 gary[i] = Atol(p);
2429             }
2430             if (i)
2431                 (void)setgroups(i, gary);
2432         }
2433 #else  /* HAS_SETGROUPS */
2434         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2435 #endif /* HAS_SETGROUPS */
2436         if (PL_delaymagic) {
2437             PL_delaymagic |= DM_EGID;
2438             break;                              /* don't do magic till later */
2439         }
2440 #ifdef HAS_SETEGID
2441         (void)setegid((Gid_t)PL_egid);
2442 #else
2443 #ifdef HAS_SETREGID
2444         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2445 #else
2446 #ifdef HAS_SETRESGID
2447         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2448 #else
2449         if (PL_egid == PL_gid)                  /* special case $) = $( */
2450             (void)PerlProc_setgid(PL_egid);
2451         else {
2452             PL_egid = PerlProc_getegid();
2453             Perl_croak(aTHX_ "setegid() not implemented");
2454         }
2455 #endif
2456 #endif
2457 #endif
2458         PL_egid = PerlProc_getegid();
2459         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2460         break;
2461     case ':':
2462         PL_chopset = SvPV_force(sv,len);
2463         break;
2464 #ifndef MACOS_TRADITIONAL
2465     case '0':
2466         LOCK_DOLLARZERO_MUTEX;
2467 #ifdef HAS_SETPROCTITLE
2468         /* The BSDs don't show the argv[] in ps(1) output, they
2469          * show a string from the process struct and provide
2470          * the setproctitle() routine to manipulate that. */
2471         {
2472             s = SvPV_const(sv, len);
2473 #   if __FreeBSD_version > 410001
2474             /* The leading "-" removes the "perl: " prefix,
2475              * but not the "(perl) suffix from the ps(1)
2476              * output, because that's what ps(1) shows if the
2477              * argv[] is modified. */
2478             setproctitle("-%s", s);
2479 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2480             /* This doesn't really work if you assume that
2481              * $0 = 'foobar'; will wipe out 'perl' from the $0
2482              * because in ps(1) output the result will be like
2483              * sprintf("perl: %s (perl)", s)
2484              * I guess this is a security feature:
2485              * one (a user process) cannot get rid of the original name.
2486              * --jhi */
2487             setproctitle("%s", s);
2488 #   endif
2489         }
2490 #endif
2491 #if defined(__hpux) && defined(PSTAT_SETCMD)
2492         {
2493              union pstun un;
2494              s = SvPV_const(sv, len);
2495              un.pst_command = (char *)s;
2496              pstat(PSTAT_SETCMD, un, len, 0, 0);
2497         }
2498 #endif
2499         /* PL_origalen is set in perl_parse(). */
2500         s = SvPV_force(sv,len);
2501         if (len >= (STRLEN)PL_origalen-1) {
2502             /* Longer than original, will be truncated. We assume that
2503              * PL_origalen bytes are available. */
2504             Copy(s, PL_origargv[0], PL_origalen-1, char);
2505         }
2506         else {
2507             /* Shorter than original, will be padded. */
2508             Copy(s, PL_origargv[0], len, char);
2509             PL_origargv[0][len] = 0;
2510             memset(PL_origargv[0] + len + 1,
2511                    /* Is the space counterintuitive?  Yes.
2512                     * (You were expecting \0?)
2513                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2514                     * --jhi */
2515                    (int)' ',
2516                    PL_origalen - len - 1);
2517         }
2518         PL_origargv[0][PL_origalen-1] = 0;
2519         for (i = 1; i < PL_origargc; i++)
2520             PL_origargv[i] = 0;
2521         UNLOCK_DOLLARZERO_MUTEX;
2522         break;
2523 #endif
2524     }
2525     return 0;
2526 }
2527
2528 I32
2529 Perl_whichsig(pTHX_ const char *sig)
2530 {
2531     register char* const* sigv;
2532
2533     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2534         if (strEQ(sig,*sigv))
2535             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2536 #ifdef SIGCLD
2537     if (strEQ(sig,"CHLD"))
2538         return SIGCLD;
2539 #endif
2540 #ifdef SIGCHLD
2541     if (strEQ(sig,"CLD"))
2542         return SIGCHLD;
2543 #endif
2544     return -1;
2545 }
2546
2547 Signal_t
2548 Perl_sighandler(int sig)
2549 {
2550 #ifdef PERL_GET_SIG_CONTEXT
2551     dTHXa(PERL_GET_SIG_CONTEXT);
2552 #else
2553     dTHX;
2554 #endif
2555     dSP;
2556     GV *gv = Nullgv;
2557     HV *st;
2558     SV *sv = Nullsv, *tSv = PL_Sv;
2559     CV *cv = Nullcv;
2560     OP *myop = PL_op;
2561     U32 flags = 0;
2562     XPV *tXpv = PL_Xpv;
2563
2564     if (PL_savestack_ix + 15 <= PL_savestack_max)
2565         flags |= 1;
2566     if (PL_markstack_ptr < PL_markstack_max - 2)
2567         flags |= 4;
2568     if (PL_scopestack_ix < PL_scopestack_max - 3)
2569         flags |= 16;
2570
2571     if (!PL_psig_ptr[sig]) {
2572                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2573                                  PL_sig_name[sig]);
2574                 exit(sig);
2575         }
2576
2577     /* Max number of items pushed there is 3*n or 4. We cannot fix
2578        infinity, so we fix 4 (in fact 5): */
2579     if (flags & 1) {
2580         PL_savestack_ix += 5;           /* Protect save in progress. */
2581         SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2582     }
2583     if (flags & 4)
2584         PL_markstack_ptr++;             /* Protect mark. */
2585     if (flags & 16)
2586         PL_scopestack_ix += 1;
2587     /* sv_2cv is too complicated, try a simpler variant first: */
2588     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2589         || SvTYPE(cv) != SVt_PVCV)
2590         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2591
2592     if (!cv || !CvROOT(cv)) {
2593         if (ckWARN(WARN_SIGNAL))
2594             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2595                 PL_sig_name[sig], (gv ? GvENAME(gv)
2596                                 : ((cv && CvGV(cv))
2597                                    ? GvENAME(CvGV(cv))
2598                                    : "__ANON__")));
2599         goto cleanup;
2600     }
2601
2602     if(PL_psig_name[sig]) {
2603         sv = SvREFCNT_inc(PL_psig_name[sig]);
2604         flags |= 64;
2605 #if !defined(PERL_IMPLICIT_CONTEXT)
2606         PL_sig_sv = sv;
2607 #endif
2608     } else {
2609         sv = sv_newmortal();
2610         sv_setpv(sv,PL_sig_name[sig]);
2611     }
2612
2613     PUSHSTACKi(PERLSI_SIGNAL);
2614     PUSHMARK(SP);
2615     PUSHs(sv);
2616     PUTBACK;
2617
2618     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2619
2620     POPSTACK;
2621     if (SvTRUE(ERRSV)) {
2622 #ifndef PERL_MICRO
2623 #ifdef HAS_SIGPROCMASK
2624         /* Handler "died", for example to get out of a restart-able read().
2625          * Before we re-do that on its behalf re-enable the signal which was
2626          * blocked by the system when we entered.
2627          */
2628         sigset_t set;
2629         sigemptyset(&set);
2630         sigaddset(&set,sig);
2631         sigprocmask(SIG_UNBLOCK, &set, NULL);
2632 #else
2633         /* Not clear if this will work */
2634         (void)rsignal(sig, SIG_IGN);
2635         (void)rsignal(sig, PL_csighandlerp);
2636 #endif
2637 #endif /* !PERL_MICRO */
2638         DieNull;
2639     }
2640 cleanup:
2641     if (flags & 1)
2642         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2643     if (flags & 4)
2644         PL_markstack_ptr--;
2645     if (flags & 16)
2646         PL_scopestack_ix -= 1;
2647     if (flags & 64)
2648         SvREFCNT_dec(sv);
2649     PL_op = myop;                       /* Apparently not needed... */
2650
2651     PL_Sv = tSv;                        /* Restore global temporaries. */
2652     PL_Xpv = tXpv;
2653     return;
2654 }
2655
2656
2657 static void
2658 restore_magic(pTHX_ const void *p)
2659 {
2660     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2661     SV* sv = mgs->mgs_sv;
2662
2663     if (!sv)
2664         return;
2665
2666     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2667     {
2668 #ifdef PERL_OLD_COPY_ON_WRITE
2669         /* While magic was saved (and off) sv_setsv may well have seen
2670            this SV as a prime candidate for COW.  */
2671         if (SvIsCOW(sv))
2672             sv_force_normal(sv);
2673 #endif
2674
2675         if (mgs->mgs_flags)
2676             SvFLAGS(sv) |= mgs->mgs_flags;
2677         else
2678             mg_magical(sv);
2679         if (SvGMAGICAL(sv))
2680             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2681     }
2682
2683     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2684
2685     /* If we're still on top of the stack, pop us off.  (That condition
2686      * will be satisfied if restore_magic was called explicitly, but *not*
2687      * if it's being called via leave_scope.)
2688      * The reason for doing this is that otherwise, things like sv_2cv()
2689      * may leave alloc gunk on the savestack, and some code
2690      * (e.g. sighandler) doesn't expect that...
2691      */
2692     if (PL_savestack_ix == mgs->mgs_ss_ix)
2693     {
2694         I32 popval = SSPOPINT;
2695         assert(popval == SAVEt_DESTRUCTOR_X);
2696         PL_savestack_ix -= 2;
2697         popval = SSPOPINT;
2698         assert(popval == SAVEt_ALLOC);
2699         popval = SSPOPINT;
2700         PL_savestack_ix -= popval;
2701     }
2702
2703 }
2704
2705 static void
2706 unwind_handler_stack(pTHX_ const void *p)
2707 {
2708     dVAR;
2709     const U32 flags = *(const U32*)p;
2710
2711     if (flags & 1)
2712         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2713     /* cxstack_ix-- Not needed, die already unwound it. */
2714 #if !defined(PERL_IMPLICIT_CONTEXT)
2715     if (flags & 64)
2716         SvREFCNT_dec(PL_sig_sv);
2717 #endif
2718 }
2719
2720 /*
2721  * Local variables:
2722  * c-indentation-style: bsd
2723  * c-basic-offset: 4
2724  * indent-tabs-mode: t
2725  * End:
2726  *
2727  * ex: set ts=8 sts=4 sw=4 noet:
2728  */