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     return 0;
1924 }
1925
1926 int
1927 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1928 {
1929     (void)sv;
1930     if (PL_tainted)
1931         mg->mg_len |= 1;
1932     else
1933         mg->mg_len &= ~1;
1934     return 0;
1935 }
1936
1937 int
1938 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1939 {
1940     SV * const lsv = LvTARG(sv);
1941     (void)mg;
1942
1943     if (!lsv) {
1944         SvOK_off(sv);
1945         return 0;
1946     }
1947
1948     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1949     return 0;
1950 }
1951
1952 int
1953 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1954 {
1955     (void)mg;
1956     do_vecset(sv);      /* XXX slurp this routine */
1957     return 0;
1958 }
1959
1960 int
1961 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1962 {
1963     SV *targ = Nullsv;
1964     if (LvTARGLEN(sv)) {
1965         if (mg->mg_obj) {
1966             SV *ahv = LvTARG(sv);
1967             HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1968             if (he)
1969                 targ = HeVAL(he);
1970         }
1971         else {
1972             AV* av = (AV*)LvTARG(sv);
1973             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1974                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1975         }
1976         if (targ && targ != &PL_sv_undef) {
1977             /* somebody else defined it for us */
1978             SvREFCNT_dec(LvTARG(sv));
1979             LvTARG(sv) = SvREFCNT_inc(targ);
1980             LvTARGLEN(sv) = 0;
1981             SvREFCNT_dec(mg->mg_obj);
1982             mg->mg_obj = Nullsv;
1983             mg->mg_flags &= ~MGf_REFCOUNTED;
1984         }
1985     }
1986     else
1987         targ = LvTARG(sv);
1988     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1989     return 0;
1990 }
1991
1992 int
1993 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1994 {
1995     (void)mg;
1996     if (LvTARGLEN(sv))
1997         vivify_defelem(sv);
1998     if (LvTARG(sv)) {
1999         sv_setsv(LvTARG(sv), sv);
2000         SvSETMAGIC(LvTARG(sv));
2001     }
2002     return 0;
2003 }
2004
2005 void
2006 Perl_vivify_defelem(pTHX_ SV *sv)
2007 {
2008     MAGIC *mg;
2009     SV *value = Nullsv;
2010
2011     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2012         return;
2013     if (mg->mg_obj) {
2014         SV *ahv = LvTARG(sv);
2015         HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2016         if (he)
2017             value = HeVAL(he);
2018         if (!value || value == &PL_sv_undef)
2019             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2020     }
2021     else {
2022         AV* av = (AV*)LvTARG(sv);
2023         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2024             LvTARG(sv) = Nullsv;        /* array can't be extended */
2025         else {
2026             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2027             if (!svp || (value = *svp) == &PL_sv_undef)
2028                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2029         }
2030     }
2031     (void)SvREFCNT_inc(value);
2032     SvREFCNT_dec(LvTARG(sv));
2033     LvTARG(sv) = value;
2034     LvTARGLEN(sv) = 0;
2035     SvREFCNT_dec(mg->mg_obj);
2036     mg->mg_obj = Nullsv;
2037     mg->mg_flags &= ~MGf_REFCOUNTED;
2038 }
2039
2040 int
2041 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2042 {
2043     AV *av = (AV*)mg->mg_obj;
2044     SV **svp = AvARRAY(av);
2045     I32 i = AvFILLp(av);
2046     (void)sv;
2047
2048     while (i >= 0) {
2049         if (svp[i]) {
2050             if (!SvWEAKREF(svp[i]))
2051                 Perl_croak(aTHX_ "panic: magic_killbackrefs");
2052             /* XXX Should we check that it hasn't changed? */
2053             SvRV_set(svp[i], 0);
2054             SvOK_off(svp[i]);
2055             SvWEAKREF_off(svp[i]);
2056             svp[i] = Nullsv;
2057         }
2058         i--;
2059     }
2060     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2061     return 0;
2062 }
2063
2064 int
2065 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2066 {
2067     mg->mg_len = -1;
2068     SvSCREAM_off(sv);
2069     return 0;
2070 }
2071
2072 int
2073 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2074 {
2075     (void)mg;
2076     sv_unmagic(sv, PERL_MAGIC_bm);
2077     SvVALID_off(sv);
2078     return 0;
2079 }
2080
2081 int
2082 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2083 {
2084     (void)mg;
2085     sv_unmagic(sv, PERL_MAGIC_fm);
2086     SvCOMPILED_off(sv);
2087     return 0;
2088 }
2089
2090 int
2091 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2092 {
2093     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2094
2095     if (uf && uf->uf_set)
2096         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2097     return 0;
2098 }
2099
2100 int
2101 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2102 {
2103     (void)mg;
2104     sv_unmagic(sv, PERL_MAGIC_qr);
2105     return 0;
2106 }
2107
2108 int
2109 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2110 {
2111     regexp *re = (regexp *)mg->mg_obj;
2112     ReREFCNT_dec(re);
2113     (void)sv;
2114     return 0;
2115 }
2116
2117 #ifdef USE_LOCALE_COLLATE
2118 int
2119 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2120 {
2121     /*
2122      * RenE<eacute> Descartes said "I think not."
2123      * and vanished with a faint plop.
2124      */
2125     (void)sv;
2126     if (mg->mg_ptr) {
2127         Safefree(mg->mg_ptr);
2128         mg->mg_ptr = NULL;
2129         mg->mg_len = -1;
2130     }
2131     return 0;
2132 }
2133 #endif /* USE_LOCALE_COLLATE */
2134
2135 /* Just clear the UTF-8 cache data. */
2136 int
2137 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2138 {
2139     (void)sv;
2140     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2141     mg->mg_ptr = 0;
2142     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2143     return 0;
2144 }
2145
2146 int
2147 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2148 {
2149     register const char *s;
2150     I32 i;
2151     STRLEN len;
2152     switch (*mg->mg_ptr) {
2153     case '\001':        /* ^A */
2154         sv_setsv(PL_bodytarget, sv);
2155         break;
2156     case '\003':        /* ^C */
2157         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2158         break;
2159
2160     case '\004':        /* ^D */
2161 #ifdef DEBUGGING
2162         s = SvPV_nolen_const(sv);
2163         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2164         DEBUG_x(dump_all());
2165 #else
2166         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2167 #endif
2168         break;
2169     case '\005':  /* ^E */
2170         if (*(mg->mg_ptr+1) == '\0') {
2171 #ifdef MACOS_TRADITIONAL
2172             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2173 #else
2174 #  ifdef VMS
2175             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2176 #  else
2177 #    ifdef WIN32
2178             SetLastError( SvIV(sv) );
2179 #    else
2180 #      ifdef OS2
2181             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2182 #      else
2183             /* will anyone ever use this? */
2184             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2185 #      endif
2186 #    endif
2187 #  endif
2188 #endif
2189         }
2190         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2191             if (PL_encoding)
2192                 SvREFCNT_dec(PL_encoding);
2193             if (SvOK(sv) || SvGMAGICAL(sv)) {
2194                 PL_encoding = newSVsv(sv);
2195             }
2196             else {
2197                 PL_encoding = Nullsv;
2198             }
2199         }
2200         break;
2201     case '\006':        /* ^F */
2202         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2203         break;
2204     case '\010':        /* ^H */
2205         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2206         break;
2207     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2208         if (PL_inplace)
2209             Safefree(PL_inplace);
2210         if (SvOK(sv))
2211             PL_inplace = savesvpv(sv);
2212         else
2213             PL_inplace = Nullch;
2214         break;
2215     case '\017':        /* ^O */
2216         if (*(mg->mg_ptr+1) == '\0') {
2217             if (PL_osname) {
2218                 Safefree(PL_osname);
2219                 PL_osname = Nullch;
2220             }
2221             if (SvOK(sv)) {
2222                 TAINT_PROPER("assigning to $^O");
2223                 PL_osname = savesvpv(sv);
2224             }
2225         }
2226         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2227             if (!PL_compiling.cop_io)
2228                 PL_compiling.cop_io = newSVsv(sv);
2229             else
2230                 sv_setsv(PL_compiling.cop_io,sv);
2231         }
2232         break;
2233     case '\020':        /* ^P */
2234         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2235         if (PL_perldb && !PL_DBsingle)
2236             init_debugger();
2237         break;
2238     case '\024':        /* ^T */
2239 #ifdef BIG_TIME
2240         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2241 #else
2242         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2243 #endif
2244         break;
2245     case '\027':        /* ^W & $^WARNING_BITS */
2246         if (*(mg->mg_ptr+1) == '\0') {
2247             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2248                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2249                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2250                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2251             }
2252         }
2253         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2254             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2255                 if (!SvPOK(sv) && PL_localizing) {
2256                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2257                     PL_compiling.cop_warnings = pWARN_NONE;
2258                     break;
2259                 }
2260                 {
2261                     STRLEN len, i;
2262                     int accumulate = 0 ;
2263                     int any_fatals = 0 ;
2264                     const char * const ptr = SvPV_const(sv, len) ;
2265                     for (i = 0 ; i < len ; ++i) {
2266                         accumulate |= ptr[i] ;
2267                         any_fatals |= (ptr[i] & 0xAA) ;
2268                     }
2269                     if (!accumulate)
2270                         PL_compiling.cop_warnings = pWARN_NONE;
2271                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2272                         PL_compiling.cop_warnings = pWARN_ALL;
2273                         PL_dowarn |= G_WARN_ONCE ;
2274                     }
2275                     else {
2276                         if (specialWARN(PL_compiling.cop_warnings))
2277                             PL_compiling.cop_warnings = newSVsv(sv) ;
2278                         else
2279                             sv_setsv(PL_compiling.cop_warnings, sv);
2280                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2281                             PL_dowarn |= G_WARN_ONCE ;
2282                     }
2283
2284                 }
2285             }
2286         }
2287         break;
2288     case '.':
2289         if (PL_localizing) {
2290             if (PL_localizing == 1)
2291                 SAVESPTR(PL_last_in_gv);
2292         }
2293         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2294             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2295         break;
2296     case '^':
2297         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2298         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2299         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2300         break;
2301     case '~':
2302         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2303         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2304         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2305         break;
2306     case '=':
2307         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2308         break;
2309     case '-':
2310         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2311         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2312             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2313         break;
2314     case '%':
2315         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2316         break;
2317     case '|':
2318         {
2319             IO *io = GvIOp(PL_defoutgv);
2320             if(!io)
2321               break;
2322             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2323                 IoFLAGS(io) &= ~IOf_FLUSH;
2324             else {
2325                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2326                     PerlIO *ofp = IoOFP(io);
2327                     if (ofp)
2328                         (void)PerlIO_flush(ofp);
2329                     IoFLAGS(io) |= IOf_FLUSH;
2330                 }
2331             }
2332         }
2333         break;
2334     case '/':
2335         SvREFCNT_dec(PL_rs);
2336         PL_rs = newSVsv(sv);
2337         break;
2338     case '\\':
2339         if (PL_ors_sv)
2340             SvREFCNT_dec(PL_ors_sv);
2341         if (SvOK(sv) || SvGMAGICAL(sv)) {
2342             PL_ors_sv = newSVsv(sv);
2343         }
2344         else {
2345             PL_ors_sv = Nullsv;
2346         }
2347         break;
2348     case ',':
2349         if (PL_ofs_sv)
2350             SvREFCNT_dec(PL_ofs_sv);
2351         if (SvOK(sv) || SvGMAGICAL(sv)) {
2352             PL_ofs_sv = newSVsv(sv);
2353         }
2354         else {
2355             PL_ofs_sv = Nullsv;
2356         }
2357         break;
2358     case '[':
2359         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2360         break;
2361     case '?':
2362 #ifdef COMPLEX_STATUS
2363         if (PL_localizing == 2) {
2364             PL_statusvalue = LvTARGOFF(sv);
2365             PL_statusvalue_vms = LvTARGLEN(sv);
2366         }
2367         else
2368 #endif
2369 #ifdef VMSISH_STATUS
2370         if (VMSISH_STATUS)
2371             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2372         else
2373 #endif
2374             STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2375         break;
2376     case '!':
2377         {
2378 #ifdef VMS
2379 #   define PERL_VMS_BANG vaxc$errno
2380 #else
2381 #   define PERL_VMS_BANG 0
2382 #endif
2383         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2384                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2385         }
2386         break;
2387     case '<':
2388         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2389         if (PL_delaymagic) {
2390             PL_delaymagic |= DM_RUID;
2391             break;                              /* don't do magic till later */
2392         }
2393 #ifdef HAS_SETRUID
2394         (void)setruid((Uid_t)PL_uid);
2395 #else
2396 #ifdef HAS_SETREUID
2397         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2398 #else
2399 #ifdef HAS_SETRESUID
2400       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2401 #else
2402         if (PL_uid == PL_euid) {                /* special case $< = $> */
2403 #ifdef PERL_DARWIN
2404             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2405             if (PL_uid != 0 && PerlProc_getuid() == 0)
2406                 (void)PerlProc_setuid(0);
2407 #endif
2408             (void)PerlProc_setuid(PL_uid);
2409         } else {
2410             PL_uid = PerlProc_getuid();
2411             Perl_croak(aTHX_ "setruid() not implemented");
2412         }
2413 #endif
2414 #endif
2415 #endif
2416         PL_uid = PerlProc_getuid();
2417         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2418         break;
2419     case '>':
2420         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2421         if (PL_delaymagic) {
2422             PL_delaymagic |= DM_EUID;
2423             break;                              /* don't do magic till later */
2424         }
2425 #ifdef HAS_SETEUID
2426         (void)seteuid((Uid_t)PL_euid);
2427 #else
2428 #ifdef HAS_SETREUID
2429         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2430 #else
2431 #ifdef HAS_SETRESUID
2432         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2433 #else
2434         if (PL_euid == PL_uid)          /* special case $> = $< */
2435             PerlProc_setuid(PL_euid);
2436         else {
2437             PL_euid = PerlProc_geteuid();
2438             Perl_croak(aTHX_ "seteuid() not implemented");
2439         }
2440 #endif
2441 #endif
2442 #endif
2443         PL_euid = PerlProc_geteuid();
2444         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2445         break;
2446     case '(':
2447         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2448         if (PL_delaymagic) {
2449             PL_delaymagic |= DM_RGID;
2450             break;                              /* don't do magic till later */
2451         }
2452 #ifdef HAS_SETRGID
2453         (void)setrgid((Gid_t)PL_gid);
2454 #else
2455 #ifdef HAS_SETREGID
2456         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2457 #else
2458 #ifdef HAS_SETRESGID
2459       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2460 #else
2461         if (PL_gid == PL_egid)                  /* special case $( = $) */
2462             (void)PerlProc_setgid(PL_gid);
2463         else {
2464             PL_gid = PerlProc_getgid();
2465             Perl_croak(aTHX_ "setrgid() not implemented");
2466         }
2467 #endif
2468 #endif
2469 #endif
2470         PL_gid = PerlProc_getgid();
2471         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2472         break;
2473     case ')':
2474 #ifdef HAS_SETGROUPS
2475         {
2476             const char *p = SvPV_const(sv, len);
2477             Groups_t gary[NGROUPS];
2478
2479             while (isSPACE(*p))
2480                 ++p;
2481             PL_egid = Atol(p);
2482             for (i = 0; i < NGROUPS; ++i) {
2483                 while (*p && !isSPACE(*p))
2484                     ++p;
2485                 while (isSPACE(*p))
2486                     ++p;
2487                 if (!*p)
2488                     break;
2489                 gary[i] = Atol(p);
2490             }
2491             if (i)
2492                 (void)setgroups(i, gary);
2493         }
2494 #else  /* HAS_SETGROUPS */
2495         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2496 #endif /* HAS_SETGROUPS */
2497         if (PL_delaymagic) {
2498             PL_delaymagic |= DM_EGID;
2499             break;                              /* don't do magic till later */
2500         }
2501 #ifdef HAS_SETEGID
2502         (void)setegid((Gid_t)PL_egid);
2503 #else
2504 #ifdef HAS_SETREGID
2505         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2506 #else
2507 #ifdef HAS_SETRESGID
2508         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2509 #else
2510         if (PL_egid == PL_gid)                  /* special case $) = $( */
2511             (void)PerlProc_setgid(PL_egid);
2512         else {
2513             PL_egid = PerlProc_getegid();
2514             Perl_croak(aTHX_ "setegid() not implemented");
2515         }
2516 #endif
2517 #endif
2518 #endif
2519         PL_egid = PerlProc_getegid();
2520         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2521         break;
2522     case ':':
2523         PL_chopset = SvPV_force(sv,len);
2524         break;
2525 #ifndef MACOS_TRADITIONAL
2526     case '0':
2527         LOCK_DOLLARZERO_MUTEX;
2528 #ifdef HAS_SETPROCTITLE
2529         /* The BSDs don't show the argv[] in ps(1) output, they
2530          * show a string from the process struct and provide
2531          * the setproctitle() routine to manipulate that. */
2532         {
2533             s = SvPV_const(sv, len);
2534 #   if __FreeBSD_version > 410001
2535             /* The leading "-" removes the "perl: " prefix,
2536              * but not the "(perl) suffix from the ps(1)
2537              * output, because that's what ps(1) shows if the
2538              * argv[] is modified. */
2539             setproctitle("-%s", s);
2540 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2541             /* This doesn't really work if you assume that
2542              * $0 = 'foobar'; will wipe out 'perl' from the $0
2543              * because in ps(1) output the result will be like
2544              * sprintf("perl: %s (perl)", s)
2545              * I guess this is a security feature:
2546              * one (a user process) cannot get rid of the original name.
2547              * --jhi */
2548             setproctitle("%s", s);
2549 #   endif
2550         }
2551 #endif
2552 #if defined(__hpux) && defined(PSTAT_SETCMD)
2553         {
2554              union pstun un;
2555              s = SvPV_const(sv, len);
2556              un.pst_command = (char *)s;
2557              pstat(PSTAT_SETCMD, un, len, 0, 0);
2558         }
2559 #endif
2560         /* PL_origalen is set in perl_parse(). */
2561         s = SvPV_force(sv,len);
2562         if (len >= (STRLEN)PL_origalen-1) {
2563             /* Longer than original, will be truncated. We assume that
2564              * PL_origalen bytes are available. */
2565             Copy(s, PL_origargv[0], PL_origalen-1, char);
2566         }
2567         else {
2568             /* Shorter than original, will be padded. */
2569             Copy(s, PL_origargv[0], len, char);
2570             PL_origargv[0][len] = 0;
2571             memset(PL_origargv[0] + len + 1,
2572                    /* Is the space counterintuitive?  Yes.
2573                     * (You were expecting \0?)
2574                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2575                     * --jhi */
2576                    (int)' ',
2577                    PL_origalen - len - 1);
2578         }
2579         PL_origargv[0][PL_origalen-1] = 0;
2580         for (i = 1; i < PL_origargc; i++)
2581             PL_origargv[i] = 0;
2582         UNLOCK_DOLLARZERO_MUTEX;
2583         break;
2584 #endif
2585     }
2586     return 0;
2587 }
2588
2589 I32
2590 Perl_whichsig(pTHX_ const char *sig)
2591 {
2592     register char* const* sigv;
2593
2594     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2595         if (strEQ(sig,*sigv))
2596             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2597 #ifdef SIGCLD
2598     if (strEQ(sig,"CHLD"))
2599         return SIGCLD;
2600 #endif
2601 #ifdef SIGCHLD
2602     if (strEQ(sig,"CLD"))
2603         return SIGCHLD;
2604 #endif
2605     return -1;
2606 }
2607
2608 Signal_t
2609 Perl_sighandler(int sig)
2610 {
2611 #ifdef PERL_GET_SIG_CONTEXT
2612     dTHXa(PERL_GET_SIG_CONTEXT);
2613 #else
2614     dTHX;
2615 #endif
2616     dSP;
2617     GV *gv = Nullgv;
2618     HV *st;
2619     SV *sv = Nullsv, *tSv = PL_Sv;
2620     CV *cv = Nullcv;
2621     OP *myop = PL_op;
2622     U32 flags = 0;
2623     XPV *tXpv = PL_Xpv;
2624
2625     if (PL_savestack_ix + 15 <= PL_savestack_max)
2626         flags |= 1;
2627     if (PL_markstack_ptr < PL_markstack_max - 2)
2628         flags |= 4;
2629     if (PL_scopestack_ix < PL_scopestack_max - 3)
2630         flags |= 16;
2631
2632     if (!PL_psig_ptr[sig]) {
2633                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2634                                  PL_sig_name[sig]);
2635                 exit(sig);
2636         }
2637
2638     /* Max number of items pushed there is 3*n or 4. We cannot fix
2639        infinity, so we fix 4 (in fact 5): */
2640     if (flags & 1) {
2641         PL_savestack_ix += 5;           /* Protect save in progress. */
2642         SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2643     }
2644     if (flags & 4)
2645         PL_markstack_ptr++;             /* Protect mark. */
2646     if (flags & 16)
2647         PL_scopestack_ix += 1;
2648     /* sv_2cv is too complicated, try a simpler variant first: */
2649     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2650         || SvTYPE(cv) != SVt_PVCV)
2651         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2652
2653     if (!cv || !CvROOT(cv)) {
2654         if (ckWARN(WARN_SIGNAL))
2655             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2656                 PL_sig_name[sig], (gv ? GvENAME(gv)
2657                                 : ((cv && CvGV(cv))
2658                                    ? GvENAME(CvGV(cv))
2659                                    : "__ANON__")));
2660         goto cleanup;
2661     }
2662
2663     if(PL_psig_name[sig]) {
2664         sv = SvREFCNT_inc(PL_psig_name[sig]);
2665         flags |= 64;
2666 #if !defined(PERL_IMPLICIT_CONTEXT)
2667         PL_sig_sv = sv;
2668 #endif
2669     } else {
2670         sv = sv_newmortal();
2671         sv_setpv(sv,PL_sig_name[sig]);
2672     }
2673
2674     PUSHSTACKi(PERLSI_SIGNAL);
2675     PUSHMARK(SP);
2676     PUSHs(sv);
2677     PUTBACK;
2678
2679     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2680
2681     POPSTACK;
2682     if (SvTRUE(ERRSV)) {
2683 #ifndef PERL_MICRO
2684 #ifdef HAS_SIGPROCMASK
2685         /* Handler "died", for example to get out of a restart-able read().
2686          * Before we re-do that on its behalf re-enable the signal which was
2687          * blocked by the system when we entered.
2688          */
2689         sigset_t set;
2690         sigemptyset(&set);
2691         sigaddset(&set,sig);
2692         sigprocmask(SIG_UNBLOCK, &set, NULL);
2693 #else
2694         /* Not clear if this will work */
2695         (void)rsignal(sig, SIG_IGN);
2696         (void)rsignal(sig, PL_csighandlerp);
2697 #endif
2698 #endif /* !PERL_MICRO */
2699         DieNull;
2700     }
2701 cleanup:
2702     if (flags & 1)
2703         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2704     if (flags & 4)
2705         PL_markstack_ptr--;
2706     if (flags & 16)
2707         PL_scopestack_ix -= 1;
2708     if (flags & 64)
2709         SvREFCNT_dec(sv);
2710     PL_op = myop;                       /* Apparently not needed... */
2711
2712     PL_Sv = tSv;                        /* Restore global temporaries. */
2713     PL_Xpv = tXpv;
2714     return;
2715 }
2716
2717
2718 static void
2719 restore_magic(pTHX_ const void *p)
2720 {
2721     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2722     SV* sv = mgs->mgs_sv;
2723
2724     if (!sv)
2725         return;
2726
2727     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2728     {
2729 #ifdef PERL_OLD_COPY_ON_WRITE
2730         /* While magic was saved (and off) sv_setsv may well have seen
2731            this SV as a prime candidate for COW.  */
2732         if (SvIsCOW(sv))
2733             sv_force_normal(sv);
2734 #endif
2735
2736         if (mgs->mgs_flags)
2737             SvFLAGS(sv) |= mgs->mgs_flags;
2738         else
2739             mg_magical(sv);
2740         if (SvGMAGICAL(sv))
2741             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2742     }
2743
2744     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2745
2746     /* If we're still on top of the stack, pop us off.  (That condition
2747      * will be satisfied if restore_magic was called explicitly, but *not*
2748      * if it's being called via leave_scope.)
2749      * The reason for doing this is that otherwise, things like sv_2cv()
2750      * may leave alloc gunk on the savestack, and some code
2751      * (e.g. sighandler) doesn't expect that...
2752      */
2753     if (PL_savestack_ix == mgs->mgs_ss_ix)
2754     {
2755         I32 popval = SSPOPINT;
2756         assert(popval == SAVEt_DESTRUCTOR_X);
2757         PL_savestack_ix -= 2;
2758         popval = SSPOPINT;
2759         assert(popval == SAVEt_ALLOC);
2760         popval = SSPOPINT;
2761         PL_savestack_ix -= popval;
2762     }
2763
2764 }
2765
2766 static void
2767 unwind_handler_stack(pTHX_ const void *p)
2768 {
2769     dVAR;
2770     const U32 flags = *(const U32*)p;
2771
2772     if (flags & 1)
2773         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2774     /* cxstack_ix-- Not needed, die already unwound it. */
2775 #if !defined(PERL_IMPLICIT_CONTEXT)
2776     if (flags & 64)
2777         SvREFCNT_dec(PL_sig_sv);
2778 #endif
2779 }
2780
2781 /*
2782  * Local variables:
2783  * c-indentation-style: bsd
2784  * c-basic-offset: 4
2785  * indent-tabs-mode: t
2786  * End:
2787  *
2788  * ex: set ts=8 sts=4 sw=4 noet:
2789  */