mg.c

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