mg.c

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