mg.c

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