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