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