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         HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1931         if (he)
1932             value = HeVAL(he);
1933         if (!value || value == &PL_sv_undef)
1934             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
1935     }
1936     else {
1937         AV* av = (AV*)LvTARG(sv);
1938         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1939             LvTARG(sv) = Nullsv;        /* array can't be extended */
1940         else {
1941             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1942             if (!svp || (value = *svp) == &PL_sv_undef)
1943                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1944         }
1945     }
1946     (void)SvREFCNT_inc(value);
1947     SvREFCNT_dec(LvTARG(sv));
1948     LvTARG(sv) = value;
1949     LvTARGLEN(sv) = 0;
1950     SvREFCNT_dec(mg->mg_obj);
1951     mg->mg_obj = Nullsv;
1952     mg->mg_flags &= ~MGf_REFCOUNTED;
1953 }
1954
1955 int
1956 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1957 {
1958     AV *av = (AV*)mg->mg_obj;
1959     SV **svp = AvARRAY(av);
1960     I32 i = AvFILLp(av);
1961     (void)sv;
1962
1963     while (i >= 0) {
1964         if (svp[i]) {
1965             if (!SvWEAKREF(svp[i]))
1966                 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1967             /* XXX Should we check that it hasn't changed? */
1968             SvRV_set(svp[i], 0);
1969             SvOK_off(svp[i]);
1970             SvWEAKREF_off(svp[i]);
1971             svp[i] = Nullsv;
1972         }
1973         i--;
1974     }
1975     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
1976     return 0;
1977 }
1978
1979 int
1980 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1981 {
1982     mg->mg_len = -1;
1983     SvSCREAM_off(sv);
1984     return 0;
1985 }
1986
1987 int
1988 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1989 {
1990     (void)mg;
1991     sv_unmagic(sv, PERL_MAGIC_bm);
1992     SvVALID_off(sv);
1993     return 0;
1994 }
1995
1996 int
1997 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1998 {
1999     (void)mg;
2000     sv_unmagic(sv, PERL_MAGIC_fm);
2001     SvCOMPILED_off(sv);
2002     return 0;
2003 }
2004
2005 int
2006 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2007 {
2008     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2009
2010     if (uf && uf->uf_set)
2011         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2012     return 0;
2013 }
2014
2015 int
2016 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2017 {
2018     (void)mg;
2019     sv_unmagic(sv, PERL_MAGIC_qr);
2020     return 0;
2021 }
2022
2023 int
2024 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2025 {
2026     regexp *re = (regexp *)mg->mg_obj;
2027     ReREFCNT_dec(re);
2028     (void)sv;
2029     return 0;
2030 }
2031
2032 #ifdef USE_LOCALE_COLLATE
2033 int
2034 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2035 {
2036     /*
2037      * RenE<eacute> Descartes said "I think not."
2038      * and vanished with a faint plop.
2039      */
2040     (void)sv;
2041     if (mg->mg_ptr) {
2042         Safefree(mg->mg_ptr);
2043         mg->mg_ptr = NULL;
2044         mg->mg_len = -1;
2045     }
2046     return 0;
2047 }
2048 #endif /* USE_LOCALE_COLLATE */
2049
2050 /* Just clear the UTF-8 cache data. */
2051 int
2052 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2053 {
2054     (void)sv;
2055     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2056     mg->mg_ptr = 0;
2057     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2058     return 0;
2059 }
2060
2061 int
2062 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2063 {
2064     register const char *s;
2065     I32 i;
2066     STRLEN len;
2067     switch (*mg->mg_ptr) {
2068     case '\001':        /* ^A */
2069         sv_setsv(PL_bodytarget, sv);
2070         break;
2071     case '\003':        /* ^C */
2072         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2073         break;
2074
2075     case '\004':        /* ^D */
2076 #ifdef DEBUGGING
2077         s = SvPV_nolen(sv);
2078         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2079         DEBUG_x(dump_all());
2080 #else
2081         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2082 #endif
2083         break;
2084     case '\005':  /* ^E */
2085         if (*(mg->mg_ptr+1) == '\0') {
2086 #ifdef MACOS_TRADITIONAL
2087             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2088 #else
2089 #  ifdef VMS
2090             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2091 #  else
2092 #    ifdef WIN32
2093             SetLastError( SvIV(sv) );
2094 #    else
2095 #      ifdef OS2
2096             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2097 #      else
2098             /* will anyone ever use this? */
2099             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2100 #      endif
2101 #    endif
2102 #  endif
2103 #endif
2104         }
2105         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2106             if (PL_encoding)
2107                 SvREFCNT_dec(PL_encoding);
2108             if (SvOK(sv) || SvGMAGICAL(sv)) {
2109                 PL_encoding = newSVsv(sv);
2110             }
2111             else {
2112                 PL_encoding = Nullsv;
2113             }
2114         }
2115         break;
2116     case '\006':        /* ^F */
2117         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2118         break;
2119     case '\010':        /* ^H */
2120         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2121         break;
2122     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2123         if (PL_inplace)
2124             Safefree(PL_inplace);
2125         if (SvOK(sv))
2126             PL_inplace = savesvpv(sv);
2127         else
2128             PL_inplace = Nullch;
2129         break;
2130     case '\017':        /* ^O */
2131         if (*(mg->mg_ptr+1) == '\0') {
2132             if (PL_osname) {
2133                 Safefree(PL_osname);
2134                 PL_osname = Nullch;
2135             }
2136             if (SvOK(sv)) {
2137                 TAINT_PROPER("assigning to $^O");
2138                 PL_osname = savesvpv(sv);
2139             }
2140         }
2141         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2142             if (!PL_compiling.cop_io)
2143                 PL_compiling.cop_io = newSVsv(sv);
2144             else
2145                 sv_setsv(PL_compiling.cop_io,sv);
2146         }
2147         break;
2148     case '\020':        /* ^P */
2149         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2150         if (PL_perldb && !PL_DBsingle)
2151             init_debugger();
2152         break;
2153     case '\024':        /* ^T */
2154 #ifdef BIG_TIME
2155         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2156 #else
2157         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2158 #endif
2159         break;
2160     case '\027':        /* ^W & $^WARNING_BITS */
2161         if (*(mg->mg_ptr+1) == '\0') {
2162             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2163                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2164                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2165                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2166             }
2167         }
2168         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2169             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2170                 if (!SvPOK(sv) && PL_localizing) {
2171                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2172                     PL_compiling.cop_warnings = pWARN_NONE;
2173                     break;
2174                 }
2175                 {
2176                     STRLEN len, i;
2177                     int accumulate = 0 ;
2178                     int any_fatals = 0 ;
2179                     const char * const ptr = (char*)SvPV(sv, len) ;
2180                     for (i = 0 ; i < len ; ++i) {
2181                         accumulate |= ptr[i] ;
2182                         any_fatals |= (ptr[i] & 0xAA) ;
2183                     }
2184                     if (!accumulate)
2185                         PL_compiling.cop_warnings = pWARN_NONE;
2186                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2187                         PL_compiling.cop_warnings = pWARN_ALL;
2188                         PL_dowarn |= G_WARN_ONCE ;
2189                     }
2190                     else {
2191                         if (specialWARN(PL_compiling.cop_warnings))
2192                             PL_compiling.cop_warnings = newSVsv(sv) ;
2193                         else
2194                             sv_setsv(PL_compiling.cop_warnings, sv);
2195                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2196                             PL_dowarn |= G_WARN_ONCE ;
2197                     }
2198
2199                 }
2200             }
2201         }
2202         break;
2203     case '.':
2204         if (PL_localizing) {
2205             if (PL_localizing == 1)
2206                 SAVESPTR(PL_last_in_gv);
2207         }
2208         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2209             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2210         break;
2211     case '^':
2212         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2213         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2214         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2215         break;
2216     case '~':
2217         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2218         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2219         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2220         break;
2221     case '=':
2222         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2223         break;
2224     case '-':
2225         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2226         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2227             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2228         break;
2229     case '%':
2230         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2231         break;
2232     case '|':
2233         {
2234             IO *io = GvIOp(PL_defoutgv);
2235             if(!io)
2236               break;
2237             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2238                 IoFLAGS(io) &= ~IOf_FLUSH;
2239             else {
2240                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2241                     PerlIO *ofp = IoOFP(io);
2242                     if (ofp)
2243                         (void)PerlIO_flush(ofp);
2244                     IoFLAGS(io) |= IOf_FLUSH;
2245                 }
2246             }
2247         }
2248         break;
2249     case '/':
2250         SvREFCNT_dec(PL_rs);
2251         PL_rs = newSVsv(sv);
2252         break;
2253     case '\\':
2254         if (PL_ors_sv)
2255             SvREFCNT_dec(PL_ors_sv);
2256         if (SvOK(sv) || SvGMAGICAL(sv)) {
2257             PL_ors_sv = newSVsv(sv);
2258         }
2259         else {
2260             PL_ors_sv = Nullsv;
2261         }
2262         break;
2263     case ',':
2264         if (PL_ofs_sv)
2265             SvREFCNT_dec(PL_ofs_sv);
2266         if (SvOK(sv) || SvGMAGICAL(sv)) {
2267             PL_ofs_sv = newSVsv(sv);
2268         }
2269         else {
2270             PL_ofs_sv = Nullsv;
2271         }
2272         break;
2273     case '#':
2274         if (PL_ofmt)
2275             Safefree(PL_ofmt);
2276         PL_ofmt = savesvpv(sv);
2277         break;
2278     case '[':
2279         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2280         break;
2281     case '?':
2282 #ifdef COMPLEX_STATUS
2283         if (PL_localizing == 2) {
2284             PL_statusvalue = LvTARGOFF(sv);
2285             PL_statusvalue_vms = LvTARGLEN(sv);
2286         }
2287         else
2288 #endif
2289 #ifdef VMSISH_STATUS
2290         if (VMSISH_STATUS)
2291             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2292         else
2293 #endif
2294             STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2295         break;
2296     case '!':
2297         {
2298 #ifdef VMS
2299 #   define PERL_VMS_BANG vaxc$errno
2300 #else
2301 #   define PERL_VMS_BANG 0
2302 #endif
2303         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2304                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2305         }
2306         break;
2307     case '<':
2308         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2309         if (PL_delaymagic) {
2310             PL_delaymagic |= DM_RUID;
2311             break;                              /* don't do magic till later */
2312         }
2313 #ifdef HAS_SETRUID
2314         (void)setruid((Uid_t)PL_uid);
2315 #else
2316 #ifdef HAS_SETREUID
2317         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2318 #else
2319 #ifdef HAS_SETRESUID
2320       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2321 #else
2322         if (PL_uid == PL_euid) {                /* special case $< = $> */
2323 #ifdef PERL_DARWIN
2324             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2325             if (PL_uid != 0 && PerlProc_getuid() == 0)
2326                 (void)PerlProc_setuid(0);
2327 #endif
2328             (void)PerlProc_setuid(PL_uid);
2329         } else {
2330             PL_uid = PerlProc_getuid();
2331             Perl_croak(aTHX_ "setruid() not implemented");
2332         }
2333 #endif
2334 #endif
2335 #endif
2336         PL_uid = PerlProc_getuid();
2337         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2338         break;
2339     case '>':
2340         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2341         if (PL_delaymagic) {
2342             PL_delaymagic |= DM_EUID;
2343             break;                              /* don't do magic till later */
2344         }
2345 #ifdef HAS_SETEUID
2346         (void)seteuid((Uid_t)PL_euid);
2347 #else
2348 #ifdef HAS_SETREUID
2349         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2350 #else
2351 #ifdef HAS_SETRESUID
2352         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2353 #else
2354         if (PL_euid == PL_uid)          /* special case $> = $< */
2355             PerlProc_setuid(PL_euid);
2356         else {
2357             PL_euid = PerlProc_geteuid();
2358             Perl_croak(aTHX_ "seteuid() not implemented");
2359         }
2360 #endif
2361 #endif
2362 #endif
2363         PL_euid = PerlProc_geteuid();
2364         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2365         break;
2366     case '(':
2367         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2368         if (PL_delaymagic) {
2369             PL_delaymagic |= DM_RGID;
2370             break;                              /* don't do magic till later */
2371         }
2372 #ifdef HAS_SETRGID
2373         (void)setrgid((Gid_t)PL_gid);
2374 #else
2375 #ifdef HAS_SETREGID
2376         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2377 #else
2378 #ifdef HAS_SETRESGID
2379       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2380 #else
2381         if (PL_gid == PL_egid)                  /* special case $( = $) */
2382             (void)PerlProc_setgid(PL_gid);
2383         else {
2384             PL_gid = PerlProc_getgid();
2385             Perl_croak(aTHX_ "setrgid() not implemented");
2386         }
2387 #endif
2388 #endif
2389 #endif
2390         PL_gid = PerlProc_getgid();
2391         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2392         break;
2393     case ')':
2394 #ifdef HAS_SETGROUPS
2395         {
2396             const char *p = SvPV(sv, len);
2397             Groups_t gary[NGROUPS];
2398
2399             while (isSPACE(*p))
2400                 ++p;
2401             PL_egid = Atol(p);
2402             for (i = 0; i < NGROUPS; ++i) {
2403                 while (*p && !isSPACE(*p))
2404                     ++p;
2405                 while (isSPACE(*p))
2406                     ++p;
2407                 if (!*p)
2408                     break;
2409                 gary[i] = Atol(p);
2410             }
2411             if (i)
2412                 (void)setgroups(i, gary);
2413         }
2414 #else  /* HAS_SETGROUPS */
2415         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2416 #endif /* HAS_SETGROUPS */
2417         if (PL_delaymagic) {
2418             PL_delaymagic |= DM_EGID;
2419             break;                              /* don't do magic till later */
2420         }
2421 #ifdef HAS_SETEGID
2422         (void)setegid((Gid_t)PL_egid);
2423 #else
2424 #ifdef HAS_SETREGID
2425         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2426 #else
2427 #ifdef HAS_SETRESGID
2428         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2429 #else
2430         if (PL_egid == PL_gid)                  /* special case $) = $( */
2431             (void)PerlProc_setgid(PL_egid);
2432         else {
2433             PL_egid = PerlProc_getegid();
2434             Perl_croak(aTHX_ "setegid() not implemented");
2435         }
2436 #endif
2437 #endif
2438 #endif
2439         PL_egid = PerlProc_getegid();
2440         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2441         break;
2442     case ':':
2443         PL_chopset = SvPV_force(sv,len);
2444         break;
2445 #ifndef MACOS_TRADITIONAL
2446     case '0':
2447         LOCK_DOLLARZERO_MUTEX;
2448 #ifdef HAS_SETPROCTITLE
2449         /* The BSDs don't show the argv[] in ps(1) output, they
2450          * show a string from the process struct and provide
2451          * the setproctitle() routine to manipulate that. */
2452         {
2453             s = SvPV(sv, len);
2454 #   if __FreeBSD_version > 410001
2455             /* The leading "-" removes the "perl: " prefix,
2456              * but not the "(perl) suffix from the ps(1)
2457              * output, because that's what ps(1) shows if the
2458              * argv[] is modified. */
2459             setproctitle("-%s", s);
2460 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2461             /* This doesn't really work if you assume that
2462              * $0 = 'foobar'; will wipe out 'perl' from the $0
2463              * because in ps(1) output the result will be like
2464              * sprintf("perl: %s (perl)", s)
2465              * I guess this is a security feature:
2466              * one (a user process) cannot get rid of the original name.
2467              * --jhi */
2468             setproctitle("%s", s);
2469 #   endif
2470         }
2471 #endif
2472 #if defined(__hpux) && defined(PSTAT_SETCMD)
2473         {
2474              union pstun un;
2475              s = SvPV(sv, len);
2476              un.pst_command = (char *)s;
2477              pstat(PSTAT_SETCMD, un, len, 0, 0);
2478         }
2479 #endif
2480         /* PL_origalen is set in perl_parse(). */
2481         s = SvPV_force(sv,len);
2482         if (len >= (STRLEN)PL_origalen-1) {
2483             /* Longer than original, will be truncated. We assume that
2484              * PL_origalen bytes are available. */
2485             Copy(s, PL_origargv[0], PL_origalen-1, char);
2486         }
2487         else {
2488             /* Shorter than original, will be padded. */
2489             Copy(s, PL_origargv[0], len, char);
2490             PL_origargv[0][len] = 0;
2491             memset(PL_origargv[0] + len + 1,
2492                    /* Is the space counterintuitive?  Yes.
2493                     * (You were expecting \0?)
2494                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2495                     * --jhi */
2496                    (int)' ',
2497                    PL_origalen - len - 1);
2498         }
2499         PL_origargv[0][PL_origalen-1] = 0;
2500         for (i = 1; i < PL_origargc; i++)
2501             PL_origargv[i] = 0;
2502         UNLOCK_DOLLARZERO_MUTEX;
2503         break;
2504 #endif
2505     }
2506     return 0;
2507 }
2508
2509 I32
2510 Perl_whichsig(pTHX_ const char *sig)
2511 {
2512     register char* const* sigv;
2513
2514     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2515         if (strEQ(sig,*sigv))
2516             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2517 #ifdef SIGCLD
2518     if (strEQ(sig,"CHLD"))
2519         return SIGCLD;
2520 #endif
2521 #ifdef SIGCHLD
2522     if (strEQ(sig,"CLD"))
2523         return SIGCHLD;
2524 #endif
2525     return -1;
2526 }
2527
2528 Signal_t
2529 Perl_sighandler(int sig)
2530 {
2531 #ifdef PERL_GET_SIG_CONTEXT
2532     dTHXa(PERL_GET_SIG_CONTEXT);
2533 #else
2534     dTHX;
2535 #endif
2536     dSP;
2537     GV *gv = Nullgv;
2538     HV *st;
2539     SV *sv = Nullsv, *tSv = PL_Sv;
2540     CV *cv = Nullcv;
2541     OP *myop = PL_op;
2542     U32 flags = 0;
2543     XPV *tXpv = PL_Xpv;
2544
2545     if (PL_savestack_ix + 15 <= PL_savestack_max)
2546         flags |= 1;
2547     if (PL_markstack_ptr < PL_markstack_max - 2)
2548         flags |= 4;
2549     if (PL_scopestack_ix < PL_scopestack_max - 3)
2550         flags |= 16;
2551
2552     if (!PL_psig_ptr[sig]) {
2553                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2554                                  PL_sig_name[sig]);
2555                 exit(sig);
2556         }
2557
2558     /* Max number of items pushed there is 3*n or 4. We cannot fix
2559        infinity, so we fix 4 (in fact 5): */
2560     if (flags & 1) {
2561         PL_savestack_ix += 5;           /* Protect save in progress. */
2562         SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2563     }
2564     if (flags & 4)
2565         PL_markstack_ptr++;             /* Protect mark. */
2566     if (flags & 16)
2567         PL_scopestack_ix += 1;
2568     /* sv_2cv is too complicated, try a simpler variant first: */
2569     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2570         || SvTYPE(cv) != SVt_PVCV)
2571         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2572
2573     if (!cv || !CvROOT(cv)) {
2574         if (ckWARN(WARN_SIGNAL))
2575             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2576                 PL_sig_name[sig], (gv ? GvENAME(gv)
2577                                 : ((cv && CvGV(cv))
2578                                    ? GvENAME(CvGV(cv))
2579                                    : "__ANON__")));
2580         goto cleanup;
2581     }
2582
2583     if(PL_psig_name[sig]) {
2584         sv = SvREFCNT_inc(PL_psig_name[sig]);
2585         flags |= 64;
2586 #if !defined(PERL_IMPLICIT_CONTEXT)
2587         PL_sig_sv = sv;
2588 #endif
2589     } else {
2590         sv = sv_newmortal();
2591         sv_setpv(sv,PL_sig_name[sig]);
2592     }
2593
2594     PUSHSTACKi(PERLSI_SIGNAL);
2595     PUSHMARK(SP);
2596     PUSHs(sv);
2597     PUTBACK;
2598
2599     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2600
2601     POPSTACK;
2602     if (SvTRUE(ERRSV)) {
2603 #ifndef PERL_MICRO
2604 #ifdef HAS_SIGPROCMASK
2605         /* Handler "died", for example to get out of a restart-able read().
2606          * Before we re-do that on its behalf re-enable the signal which was
2607          * blocked by the system when we entered.
2608          */
2609         sigset_t set;
2610         sigemptyset(&set);
2611         sigaddset(&set,sig);
2612         sigprocmask(SIG_UNBLOCK, &set, NULL);
2613 #else
2614         /* Not clear if this will work */
2615         (void)rsignal(sig, SIG_IGN);
2616         (void)rsignal(sig, PL_csighandlerp);
2617 #endif
2618 #endif /* !PERL_MICRO */
2619         DieNull;
2620     }
2621 cleanup:
2622     if (flags & 1)
2623         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2624     if (flags & 4)
2625         PL_markstack_ptr--;
2626     if (flags & 16)
2627         PL_scopestack_ix -= 1;
2628     if (flags & 64)
2629         SvREFCNT_dec(sv);
2630     PL_op = myop;                       /* Apparently not needed... */
2631
2632     PL_Sv = tSv;                        /* Restore global temporaries. */
2633     PL_Xpv = tXpv;
2634     return;
2635 }
2636
2637
2638 static void
2639 restore_magic(pTHX_ const void *p)
2640 {
2641     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2642     SV* sv = mgs->mgs_sv;
2643
2644     if (!sv)
2645         return;
2646
2647     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2648     {
2649 #ifdef PERL_COPY_ON_WRITE
2650         /* While magic was saved (and off) sv_setsv may well have seen
2651            this SV as a prime candidate for COW.  */
2652         if (SvIsCOW(sv))
2653             sv_force_normal(sv);
2654 #endif
2655
2656         if (mgs->mgs_flags)
2657             SvFLAGS(sv) |= mgs->mgs_flags;
2658         else
2659             mg_magical(sv);
2660         if (SvGMAGICAL(sv))
2661             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2662     }
2663
2664     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2665
2666     /* If we're still on top of the stack, pop us off.  (That condition
2667      * will be satisfied if restore_magic was called explicitly, but *not*
2668      * if it's being called via leave_scope.)
2669      * The reason for doing this is that otherwise, things like sv_2cv()
2670      * may leave alloc gunk on the savestack, and some code
2671      * (e.g. sighandler) doesn't expect that...
2672      */
2673     if (PL_savestack_ix == mgs->mgs_ss_ix)
2674     {
2675         I32 popval = SSPOPINT;
2676         assert(popval == SAVEt_DESTRUCTOR_X);
2677         PL_savestack_ix -= 2;
2678         popval = SSPOPINT;
2679         assert(popval == SAVEt_ALLOC);
2680         popval = SSPOPINT;
2681         PL_savestack_ix -= popval;
2682     }
2683
2684 }
2685
2686 static void
2687 unwind_handler_stack(pTHX_ const void *p)
2688 {
2689     dVAR;
2690     const U32 flags = *(const U32*)p;
2691
2692     if (flags & 1)
2693         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2694     /* cxstack_ix-- Not needed, die already unwound it. */
2695 #if !defined(PERL_IMPLICIT_CONTEXT)
2696     if (flags & 64)
2697         SvREFCNT_dec(PL_sig_sv);
2698 #endif
2699 }
2700
2701