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