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