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