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