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