mg.c

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