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