mg.c

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