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