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