mg.c

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