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