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                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 790             }
 791             else if (PL_compiling.cop_warnings == pWARN_STD) {
 792                 sv_setpvn(
 793                     sv,
 794                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 795                     WARNsize
 796                 );
 797             }
 798             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 799                 /* Get the bit mask for $warnings::Bits{all}, because
 800                  * it could have been extended by warnings::register */
 801                 SV **bits_all;
 802                 HV *bits=get_hv("warnings::Bits", FALSE);
 803                 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
 804                     sv_setsv(sv, *bits_all);
 805                 }
 806                 else {
 807                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 808                 }
 809             }
 810             else {
 811                 sv_setsv(sv, PL_compiling.cop_warnings);
 812             }
 813             SvPOK_only(sv);
 814         }
 815         break;
 816     case '1': case '2': case '3': case '4':
 817     case '5': case '6': case '7': case '8': case '9': case '&':
 818         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 819             I32 s1, t1;
 820
 821             /*
 822              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 823              * XXX Does the new way break anything?
 824              */
 825             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 826           getparen:
 827             if (paren <= (I32)rx->nparens &&
 828                 (s1 = rx->startp[paren]) != -1 &&
 829                 (t1 = rx->endp[paren]) != -1)
 830             {
 831                 i = t1 - s1;
 832                 s = rx->subbeg + s1;
 833                 if (!rx->subbeg)
 834                     break;
 835
 836               getrx:
 837                 if (i >= 0) {
 838                     sv_setpvn(sv, s, i);
 839                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 840                         SvUTF8_on(sv);
 841                     else
 842                         SvUTF8_off(sv);
 843                     if (PL_tainting) {
 844                         if (RX_MATCH_TAINTED(rx)) {
 845                             MAGIC* mg = SvMAGIC(sv);
 846                             MAGIC* mgt;
 847                             PL_tainted = 1;
 848                             SvMAGIC_set(sv, mg->mg_moremagic);
 849                             SvTAINT(sv);
 850                             if ((mgt = SvMAGIC(sv))) {
 851                                 mg->mg_moremagic = mgt;
 852                                 SvMAGIC_set(sv, mg);
 853                             }
 854                         } else
 855                             SvTAINTED_off(sv);
 856                     }
 857                     break;
 858                 }
 859             }
 860         }
 861         sv_setsv(sv,&PL_sv_undef);
 862         break;
 863     case '+':
 864         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 865             paren = rx->lastparen;
 866             if (paren)
 867                 goto getparen;
 868         }
 869         sv_setsv(sv,&PL_sv_undef);
 870         break;
 871     case '\016':                /* ^N */
 872         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 873             paren = rx->lastcloseparen;
 874             if (paren)
 875                 goto getparen;
 876         }
 877         sv_setsv(sv,&PL_sv_undef);
 878         break;
 879     case '`':
 880         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 881             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 882                 i = rx->startp[0];
 883                 goto getrx;
 884             }
 885         }
 886         sv_setsv(sv,&PL_sv_undef);
 887         break;
 888     case '\'':
 889         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 890             if (rx->subbeg && rx->endp[0] != -1) {
 891                 s = rx->subbeg + rx->endp[0];
 892                 i = rx->sublen - rx->endp[0];
 893                 goto getrx;
 894             }
 895         }
 896         sv_setsv(sv,&PL_sv_undef);
 897         break;
 898     case '.':
 899         if (GvIO(PL_last_in_gv)) {
 900             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 901         }
 902         break;
 903     case '?':
 904         {
 905             sv_setiv(sv, (IV)STATUS_CURRENT);
 906 #ifdef COMPLEX_STATUS
 907             LvTARGOFF(sv) = PL_statusvalue;
 908             LvTARGLEN(sv) = PL_statusvalue_vms;
 909 #endif
 910         }
 911         break;
 912     case '^':
 913         if (GvIOp(PL_defoutgv))
 914             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 915         if (s)
 916             sv_setpv(sv,s);
 917         else {
 918             sv_setpv(sv,GvENAME(PL_defoutgv));
 919             sv_catpv(sv,"_TOP");
 920         }
 921         break;
 922     case '~':
 923         if (GvIOp(PL_defoutgv))
 924             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 925         if (!s)
 926             s = GvENAME(PL_defoutgv);
 927         sv_setpv(sv,s);
 928         break;
 929     case '=':
 930         if (GvIOp(PL_defoutgv))
 931             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 932         break;
 933     case '-':
 934         if (GvIOp(PL_defoutgv))
 935             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 936         break;
 937     case '%':
 938         if (GvIOp(PL_defoutgv))
 939             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 940         break;
 941     case ':':
 942         break;
 943     case '/':
 944         break;
 945     case '[':
 946         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 947         break;
 948     case '|':
 949         if (GvIOp(PL_defoutgv))
 950             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 951         break;
 952     case ',':
 953         break;
 954     case '\\':
 955         if (PL_ors_sv)
 956             sv_copypv(sv, PL_ors_sv);
 957         break;
 958     case '!':
 959 #ifdef VMS
 960         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 961         sv_setpv(sv, errno ? Strerror(errno) : "");
 962 #else
 963         {
 964         const int saveerrno = errno;
 965         sv_setnv(sv, (NV)errno);
 966 #ifdef OS2
 967         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 968             sv_setpv(sv, os2error(Perl_rc));
 969         else
 970 #endif
 971         sv_setpv(sv, errno ? Strerror(errno) : "");
 972         errno = saveerrno;
 973         }
 974 #endif
 975         SvRTRIM(sv);
 976         SvNOK_on(sv);   /* what a wonderful hack! */
 977         break;
 978     case '<':
 979         sv_setiv(sv, (IV)PL_uid);
 980         break;
 981     case '>':
 982         sv_setiv(sv, (IV)PL_euid);
 983         break;
 984     case '(':
 985         sv_setiv(sv, (IV)PL_gid);
 986 #ifdef HAS_GETGROUPS
 987         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
 988 #endif
 989         goto add_groups;
 990     case ')':
 991         sv_setiv(sv, (IV)PL_egid);
 992 #ifdef HAS_GETGROUPS
 993         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
 994 #endif
 995       add_groups:
 996 #ifdef HAS_GETGROUPS
 997         {
 998             Groups_t gary[NGROUPS];
 999             I32 j = getgroups(NGROUPS,gary);
1000             while (--j >= 0)
1001                 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
1002         }
1003 #endif
1004         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1005         break;
1006 #ifndef MACOS_TRADITIONAL
1007     case '0':
1008         break;
1009 #endif
1010     }
1011     return 0;
1012 }
1013
1014 int
1015 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1016 {
1017     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1018
1019     if (uf && uf->uf_val)
1020         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1021     return 0;
1022 }
1023
1024 int
1025 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1026 {
1027     dVAR;
1028     const char *s;
1029     const char *ptr;
1030     STRLEN len, klen;
1031
1032     s = SvPV_const(sv,len);
1033     ptr = MgPV_const(mg,klen);
1034     my_setenv(ptr, s);
1035
1036 #ifdef DYNAMIC_ENV_FETCH
1037      /* We just undefd an environment var.  Is a replacement */
1038      /* waiting in the wings? */
1039     if (!len) {
1040         SV **valp;
1041         if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1042             s = SvPV_const(*valp, len);
1043     }
1044 #endif
1045
1046 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1047                             /* And you'll never guess what the dog had */
1048                             /*   in its mouth... */
1049     if (PL_tainting) {
1050         MgTAINTEDDIR_off(mg);
1051 #ifdef VMS
1052         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1053             char pathbuf[256], eltbuf[256], *cp, *elt;
1054             Stat_t sbuf;
1055             int i = 0, j = 0;
1056
1057             strncpy(eltbuf, s, 255);
1058             eltbuf[255] = 0;
1059             elt = eltbuf;
1060             do {          /* DCL$PATH may be a search list */
1061                 while (1) {   /* as may dev portion of any element */
1062                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1063                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1064                              cando_by_name(S_IWUSR,0,elt) ) {
1065                             MgTAINTEDDIR_on(mg);
1066                             return 0;
1067                         }
1068                     }
1069                     if ((cp = strchr(elt, ':')) != Nullch)
1070                         *cp = '\0';
1071                     if (my_trnlnm(elt, eltbuf, j++))
1072                         elt = eltbuf;
1073                     else
1074                         break;
1075                 }
1076                 j = 0;
1077             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1078         }
1079 #endif /* VMS */
1080         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1081             const char * const strend = s + len;
1082
1083             while (s < strend) {
1084                 char tmpbuf[256];
1085                 Stat_t st;
1086                 I32 i;
1087                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1088                              s, strend, ':', &i);
1089                 s++;
1090                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1091                       || *tmpbuf != '/'
1092                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1093                     MgTAINTEDDIR_on(mg);
1094                     return 0;
1095                 }
1096             }
1097         }
1098     }
1099 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1100
1101     return 0;
1102 }
1103
1104 int
1105 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1106 {
1107     PERL_UNUSED_ARG(sv);
1108     my_setenv(MgPV_nolen_const(mg),Nullch);
1109     return 0;
1110 }
1111
1112 int
1113 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1114 {
1115 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1116     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1117 #else
1118     if (PL_localizing) {
1119         HE* entry;
1120         magic_clear_all_env(sv,mg);
1121         hv_iterinit((HV*)sv);
1122         while ((entry = hv_iternext((HV*)sv))) {
1123             I32 keylen;
1124             my_setenv(hv_iterkey(entry, &keylen),
1125                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1126         }
1127     }
1128 #endif
1129     return 0;
1130 }
1131
1132 int
1133 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1134 {
1135     dVAR;
1136 #ifndef PERL_MICRO
1137 #if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
1138     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1139 #else
1140 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1141     PerlEnv_clearenv();
1142 #  else
1143 #    ifdef USE_ENVIRON_ARRAY
1144 #      if defined(USE_ITHREADS)
1145     /* only the parent thread can clobber the process environment */
1146     if (PL_curinterp == aTHX)
1147 #      endif
1148     {
1149 #      ifndef PERL_USE_SAFE_PUTENV
1150     if (!PL_use_safe_putenv) {
1151     I32 i;
1152
1153     if (environ == PL_origenviron)
1154         environ = (char**)safesysmalloc(sizeof(char*));
1155     else
1156         for (i = 0; environ[i]; i++)
1157             safesysfree(environ[i]);
1158     }
1159 #      endif /* PERL_USE_SAFE_PUTENV */
1160
1161     environ[0] = Nullch;
1162     }
1163 #    endif /* USE_ENVIRON_ARRAY */
1164 #   endif /* PERL_IMPLICIT_SYS || WIN32 */
1165 #endif /* VMS || EPOC */
1166 #endif /* !PERL_MICRO */
1167     PERL_UNUSED_ARG(sv);
1168     PERL_UNUSED_ARG(mg);
1169     return 0;
1170 }
1171
1172 #ifndef PERL_MICRO
1173 #ifdef HAS_SIGPROCMASK
1174 static void
1175 restore_sigmask(pTHX_ SV *save_sv)
1176 {
1177     const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1178     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1179 }
1180 #endif
1181 int
1182 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1183 {
1184     /* Are we fetching a signal entry? */
1185     const I32 i = whichsig(MgPV_nolen_const(mg));
1186     if (i > 0) {
1187         if(PL_psig_ptr[i])
1188             sv_setsv(sv,PL_psig_ptr[i]);
1189         else {
1190             Sighandler_t sigstate;
1191             sigstate = rsignal_state(i);
1192 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1193             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1194 #endif
1195 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1196             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1197 #endif
1198             /* cache state so we don't fetch it again */
1199             if(sigstate == (Sighandler_t) SIG_IGN)
1200                 sv_setpv(sv,"IGNORE");
1201             else
1202                 sv_setsv(sv,&PL_sv_undef);
1203             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1204             SvTEMP_off(sv);
1205         }
1206     }
1207     return 0;
1208 }
1209 int
1210 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1211 {
1212     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1213      * refactoring might be in order.
1214      */
1215     dVAR;
1216     register const char * const s = MgPV_nolen_const(mg);
1217     PERL_UNUSED_ARG(sv);
1218     if (*s == '_') {
1219         SV** svp = 0;
1220         if (strEQ(s,"__DIE__"))
1221             svp = &PL_diehook;
1222         else if (strEQ(s,"__WARN__"))
1223             svp = &PL_warnhook;
1224         else
1225             Perl_croak(aTHX_ "No such hook: %s", s);
1226         if (svp && *svp) {
1227             SV * const to_dec = *svp;
1228             *svp = 0;
1229             SvREFCNT_dec(to_dec);
1230         }
1231     }
1232     else {
1233         /* Are we clearing a signal entry? */
1234         const I32 i = whichsig(s);
1235         if (i > 0) {
1236 #ifdef HAS_SIGPROCMASK
1237             sigset_t set, save;
1238             SV* save_sv;
1239             /* Avoid having the signal arrive at a bad time, if possible. */
1240             sigemptyset(&set);
1241             sigaddset(&set,i);
1242             sigprocmask(SIG_BLOCK, &set, &save);
1243             ENTER;
1244             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1245             SAVEFREESV(save_sv);
1246             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1247 #endif
1248             PERL_ASYNC_CHECK();
1249 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1250             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1251 #endif
1252 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1253             PL_sig_defaulting[i] = 1;
1254             (void)rsignal(i, PL_csighandlerp);
1255 #else
1256             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1257 #endif
1258             if(PL_psig_name[i]) {
1259                 SvREFCNT_dec(PL_psig_name[i]);
1260                 PL_psig_name[i]=0;
1261             }
1262             if(PL_psig_ptr[i]) {
1263                 SV *to_dec=PL_psig_ptr[i];
1264                 PL_psig_ptr[i]=0;
1265                 LEAVE;
1266                 SvREFCNT_dec(to_dec);
1267             }
1268             else
1269                 LEAVE;
1270         }
1271     }
1272     return 0;
1273 }
1274
1275 static void
1276 S_raise_signal(pTHX_ int sig)
1277 {
1278     /* Set a flag to say this signal is pending */
1279     PL_psig_pend[sig]++;
1280     /* And one to say _a_ signal is pending */
1281     PL_sig_pending = 1;
1282 }
1283
1284 Signal_t
1285 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1286 Perl_csighandler(int sig, ...)
1287 #else
1288 Perl_csighandler(int sig)
1289 #endif
1290 {
1291 #ifdef PERL_GET_SIG_CONTEXT
1292     dTHXa(PERL_GET_SIG_CONTEXT);
1293 #else
1294     dTHX;
1295 #endif
1296 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1297     (void) rsignal(sig, PL_csighandlerp);
1298     if (PL_sig_ignoring[sig]) return;
1299 #endif
1300 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1301     if (PL_sig_defaulting[sig])
1302 #ifdef KILL_BY_SIGPRC
1303             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1304 #else
1305             exit(1);
1306 #endif
1307 #endif
1308    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1309         /* Call the perl level handler now--
1310          * with risk we may be in malloc() etc. */
1311         (*PL_sighandlerp)(sig);
1312    else
1313         S_raise_signal(aTHX_ sig);
1314 }
1315
1316 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1317 void
1318 Perl_csighandler_init(void)
1319 {
1320     int sig;
1321     if (PL_sig_handlers_initted) return;
1322
1323     for (sig = 1; sig < SIG_SIZE; sig++) {
1324 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1325         dTHX;
1326         PL_sig_defaulting[sig] = 1;
1327         (void) rsignal(sig, PL_csighandlerp);
1328 #endif
1329 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1330         PL_sig_ignoring[sig] = 0;
1331 #endif
1332     }
1333     PL_sig_handlers_initted = 1;
1334 }
1335 #endif
1336
1337 void
1338 Perl_despatch_signals(pTHX)
1339 {
1340     int sig;
1341     PL_sig_pending = 0;
1342     for (sig = 1; sig < SIG_SIZE; sig++) {
1343         if (PL_psig_pend[sig]) {
1344             PERL_BLOCKSIG_ADD(set, sig);
1345             PL_psig_pend[sig] = 0;
1346             PERL_BLOCKSIG_BLOCK(set);
1347             (*PL_sighandlerp)(sig);
1348             PERL_BLOCKSIG_UNBLOCK(set);
1349         }
1350     }
1351 }
1352
1353 int
1354 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1355 {
1356     dVAR;
1357     I32 i;
1358     SV** svp = 0;
1359     /* Need to be careful with SvREFCNT_dec(), because that can have side
1360      * effects (due to closures). We must make sure that the new disposition
1361      * is in place before it is called.
1362      */
1363     SV* to_dec = 0;
1364     STRLEN len;
1365 #ifdef HAS_SIGPROCMASK
1366     sigset_t set, save;
1367     SV* save_sv;
1368 #endif
1369
1370     register const char *s = MgPV_const(mg,len);
1371     if (*s == '_') {
1372         if (strEQ(s,"__DIE__"))
1373             svp = &PL_diehook;
1374         else if (strEQ(s,"__WARN__"))
1375             svp = &PL_warnhook;
1376         else
1377             Perl_croak(aTHX_ "No such hook: %s", s);
1378         i = 0;
1379         if (*svp) {
1380             to_dec = *svp;
1381             *svp = 0;
1382         }
1383     }
1384     else {
1385         i = whichsig(s);        /* ...no, a brick */
1386         if (i <= 0) {
1387             if (ckWARN(WARN_SIGNAL))
1388                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1389             return 0;
1390         }
1391 #ifdef HAS_SIGPROCMASK
1392         /* Avoid having the signal arrive at a bad time, if possible. */
1393         sigemptyset(&set);
1394         sigaddset(&set,i);
1395         sigprocmask(SIG_BLOCK, &set, &save);
1396         ENTER;
1397         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1398         SAVEFREESV(save_sv);
1399         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1400 #endif
1401         PERL_ASYNC_CHECK();
1402 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1403         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1404 #endif
1405 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1406         PL_sig_ignoring[i] = 0;
1407 #endif
1408 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1409         PL_sig_defaulting[i] = 0;
1410 #endif
1411         SvREFCNT_dec(PL_psig_name[i]);
1412         to_dec = PL_psig_ptr[i];
1413         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1414         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1415         PL_psig_name[i] = newSVpvn(s, len);
1416         SvREADONLY_on(PL_psig_name[i]);
1417     }
1418     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1419         if (i) {
1420             (void)rsignal(i, PL_csighandlerp);
1421 #ifdef HAS_SIGPROCMASK
1422             LEAVE;
1423 #endif
1424         }
1425         else
1426             *svp = SvREFCNT_inc(sv);
1427         if(to_dec)
1428             SvREFCNT_dec(to_dec);
1429         return 0;
1430     }
1431     s = SvPV_force(sv,len);
1432     if (strEQ(s,"IGNORE")) {
1433         if (i) {
1434 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1435             PL_sig_ignoring[i] = 1;
1436             (void)rsignal(i, PL_csighandlerp);
1437 #else
1438             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1439 #endif
1440         }
1441     }
1442     else if (strEQ(s,"DEFAULT") || !*s) {
1443         if (i)
1444 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1445           {
1446             PL_sig_defaulting[i] = 1;
1447             (void)rsignal(i, PL_csighandlerp);
1448           }
1449 #else
1450             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1451 #endif
1452     }
1453     else {
1454         /*
1455          * We should warn if HINT_STRICT_REFS, but without
1456          * access to a known hint bit in a known OP, we can't
1457          * tell whether HINT_STRICT_REFS is in force or not.
1458          */
1459         if (!strchr(s,':') && !strchr(s,'\''))
1460             sv_insert(sv, 0, 0, "main::", 6);
1461         if (i)
1462             (void)rsignal(i, PL_csighandlerp);
1463         else
1464             *svp = SvREFCNT_inc(sv);
1465     }
1466 #ifdef HAS_SIGPROCMASK
1467     if(i)
1468         LEAVE;
1469 #endif
1470     if(to_dec)
1471         SvREFCNT_dec(to_dec);
1472     return 0;
1473 }
1474 #endif /* !PERL_MICRO */
1475
1476 int
1477 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1478 {
1479     PERL_UNUSED_ARG(sv);
1480     PERL_UNUSED_ARG(mg);
1481     PL_sub_generation++;
1482     return 0;
1483 }
1484
1485 int
1486 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1487 {
1488     PERL_UNUSED_ARG(sv);
1489     PERL_UNUSED_ARG(mg);
1490     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1491     PL_amagic_generation++;
1492
1493     return 0;
1494 }
1495
1496 int
1497 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1498 {
1499     HV * const hv = (HV*)LvTARG(sv);
1500     I32 i = 0;
1501     PERL_UNUSED_ARG(mg);
1502
1503     if (hv) {
1504          (void) hv_iterinit(hv);
1505          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1506              i = HvKEYS(hv);
1507          else {
1508              while (hv_iternext(hv))
1509                  i++;
1510          }
1511     }
1512
1513     sv_setiv(sv, (IV)i);
1514     return 0;
1515 }
1516
1517 int
1518 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1519 {
1520     PERL_UNUSED_ARG(mg);
1521     if (LvTARG(sv)) {
1522         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1523     }
1524     return 0;
1525 }
1526
1527 /* caller is responsible for stack switching/cleanup */
1528 STATIC int
1529 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1530 {
1531     dSP;
1532
1533     PUSHMARK(SP);
1534     EXTEND(SP, n);
1535     PUSHs(SvTIED_obj(sv, mg));
1536     if (n > 1) {
1537         if (mg->mg_ptr) {
1538             if (mg->mg_len >= 0)
1539                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1540             else if (mg->mg_len == HEf_SVKEY)
1541                 PUSHs((SV*)mg->mg_ptr);
1542         }
1543         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1544             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1545         }
1546     }
1547     if (n > 2) {
1548         PUSHs(val);
1549     }
1550     PUTBACK;
1551
1552     return call_method(meth, flags);
1553 }
1554
1555 STATIC int
1556 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1557 {
1558     dVAR; dSP;
1559
1560     ENTER;
1561     SAVETMPS;
1562     PUSHSTACKi(PERLSI_MAGIC);
1563
1564     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1565         sv_setsv(sv, *PL_stack_sp--);
1566     }
1567
1568     POPSTACK;
1569     FREETMPS;
1570     LEAVE;
1571     return 0;
1572 }
1573
1574 int
1575 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1576 {
1577     if (mg->mg_ptr)
1578         mg->mg_flags |= MGf_GSKIP;
1579     magic_methpack(sv,mg,"FETCH");
1580     return 0;
1581 }
1582
1583 int
1584 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1585 {
1586     dVAR; dSP;
1587     ENTER;
1588     PUSHSTACKi(PERLSI_MAGIC);
1589     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1590     POPSTACK;
1591     LEAVE;
1592     return 0;
1593 }
1594
1595 int
1596 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1597 {
1598     return magic_methpack(sv,mg,"DELETE");
1599 }
1600
1601
1602 U32
1603 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1604 {
1605     dVAR; dSP;
1606     U32 retval = 0;
1607
1608     ENTER;
1609     SAVETMPS;
1610     PUSHSTACKi(PERLSI_MAGIC);
1611     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1612         sv = *PL_stack_sp--;
1613         retval = (U32) SvIV(sv)-1;
1614     }
1615     POPSTACK;
1616     FREETMPS;
1617     LEAVE;
1618     return retval;
1619 }
1620
1621 int
1622 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1623 {
1624     dVAR; dSP;
1625
1626     ENTER;
1627     PUSHSTACKi(PERLSI_MAGIC);
1628     PUSHMARK(SP);
1629     XPUSHs(SvTIED_obj(sv, mg));
1630     PUTBACK;
1631     call_method("CLEAR", G_SCALAR|G_DISCARD);
1632     POPSTACK;
1633     LEAVE;
1634
1635     return 0;
1636 }
1637
1638 int
1639 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1640 {
1641     dVAR; dSP;
1642     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1643
1644     ENTER;
1645     SAVETMPS;
1646     PUSHSTACKi(PERLSI_MAGIC);
1647     PUSHMARK(SP);
1648     EXTEND(SP, 2);
1649     PUSHs(SvTIED_obj(sv, mg));
1650     if (SvOK(key))
1651         PUSHs(key);
1652     PUTBACK;
1653
1654     if (call_method(meth, G_SCALAR))
1655         sv_setsv(key, *PL_stack_sp--);
1656
1657     POPSTACK;
1658     FREETMPS;
1659     LEAVE;
1660     return 0;
1661 }
1662
1663 int
1664 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1665 {
1666     return magic_methpack(sv,mg,"EXISTS");
1667 }
1668
1669 SV *
1670 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1671 {
1672     dVAR; dSP;
1673     SV *retval = &PL_sv_undef;
1674     SV * const tied = SvTIED_obj((SV*)hv, mg);
1675     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1676
1677     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1678         SV *key;
1679         if (HvEITER_get(hv))
1680             /* we are in an iteration so the hash cannot be empty */
1681             return &PL_sv_yes;
1682         /* no xhv_eiter so now use FIRSTKEY */
1683         key = sv_newmortal();
1684         magic_nextpack((SV*)hv, mg, key);
1685         HvEITER_set(hv, NULL);     /* need to reset iterator */
1686         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1687     }
1688
1689     /* there is a SCALAR method that we can call */
1690     ENTER;
1691     PUSHSTACKi(PERLSI_MAGIC);
1692     PUSHMARK(SP);
1693     EXTEND(SP, 1);
1694     PUSHs(tied);
1695     PUTBACK;
1696
1697     if (call_method("SCALAR", G_SCALAR))
1698         retval = *PL_stack_sp--;
1699     POPSTACK;
1700     LEAVE;
1701     return retval;
1702 }
1703
1704 int
1705 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1706 {
1707     GV * const gv = PL_DBline;
1708     const I32 i = SvTRUE(sv);
1709     SV ** const svp = av_fetch(GvAV(gv),
1710                      atoi(MgPV_nolen_const(mg)), FALSE);
1711     if (svp && SvIOKp(*svp)) {
1712         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1713         if (o) {
1714             /* set or clear breakpoint in the relevant control op */
1715             if (i)
1716                 o->op_flags |= OPf_SPECIAL;
1717             else
1718                 o->op_flags &= ~OPf_SPECIAL;
1719         }
1720     }
1721     return 0;
1722 }
1723
1724 int
1725 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1726 {
1727     const AV * const obj = (AV*)mg->mg_obj;
1728     if (obj) {
1729         sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1730     } else {
1731         SvOK_off(sv);
1732     }
1733     return 0;
1734 }
1735
1736 int
1737 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1738 {
1739     AV * const obj = (AV*)mg->mg_obj;
1740     if (obj) {
1741         av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1742     } else {
1743         if (ckWARN(WARN_MISC))
1744             Perl_warner(aTHX_ packWARN(WARN_MISC),
1745                         "Attempt to set length of freed array");
1746     }
1747     return 0;
1748 }
1749
1750 int
1751 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1752 {
1753     PERL_UNUSED_ARG(sv);
1754     /* during global destruction, mg_obj may already have been freed */
1755     if (PL_in_clean_all)
1756         return 0;
1757
1758     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1759
1760     if (mg) {
1761         /* arylen scalar holds a pointer back to the array, but doesn't own a
1762            reference. Hence the we (the array) are about to go away with it
1763            still pointing at us. Clear its pointer, else it would be pointing
1764            at free memory. See the comment in sv_magic about reference loops,
1765            and why it can't own a reference to us.  */
1766         mg->mg_obj = 0;
1767     }
1768     return 0;
1769 }
1770
1771 int
1772 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1773 {
1774     SV* const lsv = LvTARG(sv);
1775
1776     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1777         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1778         if (mg && mg->mg_len >= 0) {
1779             I32 i = mg->mg_len;
1780             if (DO_UTF8(lsv))
1781                 sv_pos_b2u(lsv, &i);
1782             sv_setiv(sv, i + PL_curcop->cop_arybase);
1783             return 0;
1784         }
1785     }
1786     SvOK_off(sv);
1787     return 0;
1788 }
1789
1790 int
1791 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1792 {
1793     SV* const lsv = LvTARG(sv);
1794     SSize_t pos;
1795     STRLEN len;
1796     STRLEN ulen = 0;
1797
1798     mg = 0;
1799
1800     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1801         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1802     if (!mg) {
1803         if (!SvOK(sv))
1804             return 0;
1805         sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1806         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1807     }
1808     else if (!SvOK(sv)) {
1809         mg->mg_len = -1;
1810         return 0;
1811     }
1812     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1813
1814     pos = SvIV(sv) - PL_curcop->cop_arybase;
1815
1816     if (DO_UTF8(lsv)) {
1817         ulen = sv_len_utf8(lsv);
1818         if (ulen)
1819             len = ulen;
1820     }
1821
1822     if (pos < 0) {
1823         pos += len;
1824         if (pos < 0)
1825             pos = 0;
1826     }
1827     else if (pos > (SSize_t)len)
1828         pos = len;
1829
1830     if (ulen) {
1831         I32 p = pos;
1832         sv_pos_u2b(lsv, &p, 0);
1833         pos = p;
1834     }
1835
1836     mg->mg_len = pos;
1837     mg->mg_flags &= ~MGf_MINMATCH;
1838
1839     return 0;
1840 }
1841
1842 int
1843 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1844 {
1845     PERL_UNUSED_ARG(mg);
1846     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1847         SvFAKE_off(sv);
1848         gv_efullname3(sv,((GV*)sv), "*");
1849         SvFAKE_on(sv);
1850     }
1851     else
1852         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1853     return 0;
1854 }
1855
1856 int
1857 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1858 {
1859     GV* gv;
1860     PERL_UNUSED_ARG(mg);
1861
1862     if (!SvOK(sv))
1863         return 0;
1864     gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1865     if (sv == (SV*)gv)
1866         return 0;
1867     if (GvGP(sv))
1868         gp_free((GV*)sv);
1869     GvGP(sv) = gp_ref(GvGP(gv));
1870     return 0;
1871 }
1872
1873 int
1874 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1875 {
1876     STRLEN len;
1877     SV * const lsv = LvTARG(sv);
1878     const char * const tmps = SvPV_const(lsv,len);
1879     I32 offs = LvTARGOFF(sv);
1880     I32 rem = LvTARGLEN(sv);
1881     PERL_UNUSED_ARG(mg);
1882
1883     if (SvUTF8(lsv))
1884         sv_pos_u2b(lsv, &offs, &rem);
1885     if (offs > (I32)len)
1886         offs = len;
1887     if (rem + offs > (I32)len)
1888         rem = len - offs;
1889     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1890     if (SvUTF8(lsv))
1891         SvUTF8_on(sv);
1892     return 0;
1893 }
1894
1895 int
1896 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1897 {
1898     STRLEN len;
1899     const char *tmps = SvPV_const(sv, len);
1900     SV * const lsv = LvTARG(sv);
1901     I32 lvoff = LvTARGOFF(sv);
1902     I32 lvlen = LvTARGLEN(sv);
1903     PERL_UNUSED_ARG(mg);
1904
1905     if (DO_UTF8(sv)) {
1906         sv_utf8_upgrade(lsv);
1907         sv_pos_u2b(lsv, &lvoff, &lvlen);
1908         sv_insert(lsv, lvoff, lvlen, tmps, len);
1909         LvTARGLEN(sv) = sv_len_utf8(sv);
1910         SvUTF8_on(lsv);
1911     }
1912     else if (lsv && SvUTF8(lsv)) {
1913         sv_pos_u2b(lsv, &lvoff, &lvlen);
1914         LvTARGLEN(sv) = len;
1915         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1916         sv_insert(lsv, lvoff, lvlen, tmps, len);
1917         Safefree(tmps);
1918     }
1919     else {
1920         sv_insert(lsv, lvoff, lvlen, tmps, len);
1921         LvTARGLEN(sv) = len;
1922     }
1923
1924
1925     return 0;
1926 }
1927
1928 int
1929 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1930 {
1931     PERL_UNUSED_ARG(sv);
1932     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1933     return 0;
1934 }
1935
1936 int
1937 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1938 {
1939     PERL_UNUSED_ARG(sv);
1940     /* update taint status unless we're restoring at scope exit */
1941     if (PL_localizing != 2) {
1942         if (PL_tainted)
1943             mg->mg_len |= 1;
1944         else
1945             mg->mg_len &= ~1;
1946     }
1947     return 0;
1948 }
1949
1950 int
1951 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1952 {
1953     SV * const lsv = LvTARG(sv);
1954     PERL_UNUSED_ARG(mg);
1955
1956     if (!lsv) {
1957         SvOK_off(sv);
1958         return 0;
1959     }
1960
1961     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1962     return 0;
1963 }
1964
1965 int
1966 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1967 {
1968     PERL_UNUSED_ARG(mg);
1969     do_vecset(sv);      /* XXX slurp this routine */
1970     return 0;
1971 }
1972
1973 int
1974 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1975 {
1976     SV *targ = Nullsv;
1977     if (LvTARGLEN(sv)) {
1978         if (mg->mg_obj) {
1979             SV * const ahv = LvTARG(sv);
1980             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1981             if (he)
1982                 targ = HeVAL(he);
1983         }
1984         else {
1985             AV* const av = (AV*)LvTARG(sv);
1986             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1987                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1988         }
1989         if (targ && targ != &PL_sv_undef) {
1990             /* somebody else defined it for us */
1991             SvREFCNT_dec(LvTARG(sv));
1992             LvTARG(sv) = SvREFCNT_inc(targ);
1993             LvTARGLEN(sv) = 0;
1994             SvREFCNT_dec(mg->mg_obj);
1995             mg->mg_obj = Nullsv;
1996             mg->mg_flags &= ~MGf_REFCOUNTED;
1997         }
1998     }
1999     else
2000         targ = LvTARG(sv);
2001     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2002     return 0;
2003 }
2004
2005 int
2006 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2007 {
2008     PERL_UNUSED_ARG(mg);
2009     if (LvTARGLEN(sv))
2010         vivify_defelem(sv);
2011     if (LvTARG(sv)) {
2012         sv_setsv(LvTARG(sv), sv);
2013         SvSETMAGIC(LvTARG(sv));
2014     }
2015     return 0;
2016 }
2017
2018 void
2019 Perl_vivify_defelem(pTHX_ SV *sv)
2020 {
2021     MAGIC *mg;
2022     SV *value = Nullsv;
2023
2024     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2025         return;
2026     if (mg->mg_obj) {
2027         SV * const ahv = LvTARG(sv);
2028         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2029         if (he)
2030             value = HeVAL(he);
2031         if (!value || value == &PL_sv_undef)
2032             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2033     }
2034     else {
2035         AV* const av = (AV*)LvTARG(sv);
2036         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2037             LvTARG(sv) = Nullsv;        /* array can't be extended */
2038         else {
2039             SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2040             if (!svp || (value = *svp) == &PL_sv_undef)
2041                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2042         }
2043     }
2044     (void)SvREFCNT_inc(value);
2045     SvREFCNT_dec(LvTARG(sv));
2046     LvTARG(sv) = value;
2047     LvTARGLEN(sv) = 0;
2048     SvREFCNT_dec(mg->mg_obj);
2049     mg->mg_obj = Nullsv;
2050     mg->mg_flags &= ~MGf_REFCOUNTED;
2051 }
2052
2053 int
2054 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2055 {
2056     AV *const av = (AV*)mg->mg_obj;
2057     SV **svp = AvARRAY(av);
2058     PERL_UNUSED_ARG(sv);
2059
2060     if (svp) {
2061         SV *const *const last = svp + AvFILLp(av);
2062
2063         while (svp <= last) {
2064             if (*svp) {
2065                 SV *const referrer = *svp;
2066                 if (SvWEAKREF(referrer)) {
2067                     /* XXX Should we check that it hasn't changed? */
2068                     SvRV_set(referrer, 0);
2069                     SvOK_off(referrer);
2070                     SvWEAKREF_off(referrer);
2071                 } else if (SvTYPE(referrer) == SVt_PVGV ||
2072                            SvTYPE(referrer) == SVt_PVLV) {
2073                     /* You lookin' at me?  */
2074                     assert(GvSTASH(referrer));
2075                     assert(GvSTASH(referrer) == (HV*)sv);
2076                     GvSTASH(referrer) = 0;
2077                 } else {
2078                     Perl_croak(aTHX_
2079                                "panic: magic_killbackrefs (flags=%"UVxf")",
2080                                (UV)SvFLAGS(referrer));
2081                 }
2082
2083                 *svp = Nullsv;
2084             }
2085             svp++;
2086         }
2087     }
2088     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2089     return 0;
2090 }
2091
2092 int
2093 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2094 {
2095     mg->mg_len = -1;
2096     SvSCREAM_off(sv);
2097     return 0;
2098 }
2099
2100 int
2101 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2102 {
2103     PERL_UNUSED_ARG(mg);
2104     sv_unmagic(sv, PERL_MAGIC_bm);
2105     SvVALID_off(sv);
2106     return 0;
2107 }
2108
2109 int
2110 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2111 {
2112     PERL_UNUSED_ARG(mg);
2113     sv_unmagic(sv, PERL_MAGIC_fm);
2114     SvCOMPILED_off(sv);
2115     return 0;
2116 }
2117
2118 int
2119 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2120 {
2121     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2122
2123     if (uf && uf->uf_set)
2124         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2125     return 0;
2126 }
2127
2128 int
2129 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2130 {
2131     PERL_UNUSED_ARG(mg);
2132     sv_unmagic(sv, PERL_MAGIC_qr);
2133     return 0;
2134 }
2135
2136 int
2137 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2138 {
2139     regexp * const re = (regexp *)mg->mg_obj;
2140     PERL_UNUSED_ARG(sv);
2141
2142     ReREFCNT_dec(re);
2143     return 0;
2144 }
2145
2146 #ifdef USE_LOCALE_COLLATE
2147 int
2148 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2149 {
2150     /*
2151      * RenE<eacute> Descartes said "I think not."
2152      * and vanished with a faint plop.
2153      */
2154     PERL_UNUSED_ARG(sv);
2155     if (mg->mg_ptr) {
2156         Safefree(mg->mg_ptr);
2157         mg->mg_ptr = NULL;
2158         mg->mg_len = -1;
2159     }
2160     return 0;
2161 }
2162 #endif /* USE_LOCALE_COLLATE */
2163
2164 /* Just clear the UTF-8 cache data. */
2165 int
2166 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2167 {
2168     PERL_UNUSED_ARG(sv);
2169     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2170     mg->mg_ptr = 0;
2171     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2172     return 0;
2173 }
2174
2175 int
2176 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2177 {
2178     register const char *s;
2179     I32 i;
2180     STRLEN len;
2181     switch (*mg->mg_ptr) {
2182     case '\001':        /* ^A */
2183         sv_setsv(PL_bodytarget, sv);
2184         break;
2185     case '\003':        /* ^C */
2186         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2187         break;
2188
2189     case '\004':        /* ^D */
2190 #ifdef DEBUGGING
2191         s = SvPV_nolen_const(sv);
2192         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2193         DEBUG_x(dump_all());
2194 #else
2195         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2196 #endif
2197         break;
2198     case '\005':  /* ^E */
2199         if (*(mg->mg_ptr+1) == '\0') {
2200 #ifdef MACOS_TRADITIONAL
2201             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2202 #else
2203 #  ifdef VMS
2204             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2205 #  else
2206 #    ifdef WIN32
2207             SetLastError( SvIV(sv) );
2208 #    else
2209 #      ifdef OS2
2210             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2211 #      else
2212             /* will anyone ever use this? */
2213             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2214 #      endif
2215 #    endif
2216 #  endif
2217 #endif
2218         }
2219         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2220             if (PL_encoding)
2221                 SvREFCNT_dec(PL_encoding);
2222             if (SvOK(sv) || SvGMAGICAL(sv)) {
2223                 PL_encoding = newSVsv(sv);
2224             }
2225             else {
2226                 PL_encoding = Nullsv;
2227             }
2228         }
2229         break;
2230     case '\006':        /* ^F */
2231         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2232         break;
2233     case '\010':        /* ^H */
2234         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2235         break;
2236     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2237         Safefree(PL_inplace);
2238         PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2239         break;
2240     case '\017':        /* ^O */
2241         if (*(mg->mg_ptr+1) == '\0') {
2242             Safefree(PL_osname);
2243             PL_osname = Nullch;
2244             if (SvOK(sv)) {
2245                 TAINT_PROPER("assigning to $^O");
2246                 PL_osname = savesvpv(sv);
2247             }
2248         }
2249         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2250             if (!PL_compiling.cop_io)
2251                 PL_compiling.cop_io = newSVsv(sv);
2252             else
2253                 sv_setsv(PL_compiling.cop_io,sv);
2254         }
2255         break;
2256     case '\020':        /* ^P */
2257         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2258         if (PL_perldb && !PL_DBsingle)
2259             init_debugger();
2260         break;
2261     case '\024':        /* ^T */
2262 #ifdef BIG_TIME
2263         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2264 #else
2265         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2266 #endif
2267         break;
2268     case '\027':        /* ^W & $^WARNING_BITS */
2269         if (*(mg->mg_ptr+1) == '\0') {
2270             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2271                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2272                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2273                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2274             }
2275         }
2276         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2277             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2278                 if (!SvPOK(sv) && PL_localizing) {
2279                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2280                     PL_compiling.cop_warnings = pWARN_NONE;
2281                     break;
2282                 }
2283                 {
2284                     STRLEN len, i;
2285                     int accumulate = 0 ;
2286                     int any_fatals = 0 ;
2287                     const char * const ptr = SvPV_const(sv, len) ;
2288                     for (i = 0 ; i < len ; ++i) {
2289                         accumulate |= ptr[i] ;
2290                         any_fatals |= (ptr[i] & 0xAA) ;
2291                     }
2292                     if (!accumulate)
2293                         PL_compiling.cop_warnings = pWARN_NONE;
2294                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2295                         PL_compiling.cop_warnings = pWARN_ALL;
2296                         PL_dowarn |= G_WARN_ONCE ;
2297                     }
2298                     else {
2299                         if (specialWARN(PL_compiling.cop_warnings))
2300                             PL_compiling.cop_warnings = newSVsv(sv) ;
2301                         else
2302                             sv_setsv(PL_compiling.cop_warnings, sv);
2303                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2304                             PL_dowarn |= G_WARN_ONCE ;
2305                     }
2306
2307                 }
2308             }
2309         }
2310         break;
2311     case '.':
2312         if (PL_localizing) {
2313             if (PL_localizing == 1)
2314                 SAVESPTR(PL_last_in_gv);
2315         }
2316         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2317             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2318         break;
2319     case '^':
2320         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2321         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2322         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2323         break;
2324     case '~':
2325         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2326         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2327         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2328         break;
2329     case '=':
2330         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2331         break;
2332     case '-':
2333         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2334         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2335             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2336         break;
2337     case '%':
2338         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2339         break;
2340     case '|':
2341         {
2342             IO * const io = GvIOp(PL_defoutgv);
2343             if(!io)
2344               break;
2345             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2346                 IoFLAGS(io) &= ~IOf_FLUSH;
2347             else {
2348                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2349                     PerlIO *ofp = IoOFP(io);
2350                     if (ofp)
2351                         (void)PerlIO_flush(ofp);
2352                     IoFLAGS(io) |= IOf_FLUSH;
2353                 }
2354             }
2355         }
2356         break;
2357     case '/':
2358         SvREFCNT_dec(PL_rs);
2359         PL_rs = newSVsv(sv);
2360         break;
2361     case '\\':
2362         if (PL_ors_sv)
2363             SvREFCNT_dec(PL_ors_sv);
2364         if (SvOK(sv) || SvGMAGICAL(sv)) {
2365             PL_ors_sv = newSVsv(sv);
2366         }
2367         else {
2368             PL_ors_sv = Nullsv;
2369         }
2370         break;
2371     case ',':
2372         if (PL_ofs_sv)
2373             SvREFCNT_dec(PL_ofs_sv);
2374         if (SvOK(sv) || SvGMAGICAL(sv)) {
2375             PL_ofs_sv = newSVsv(sv);
2376         }
2377         else {
2378             PL_ofs_sv = Nullsv;
2379         }
2380         break;
2381     case '[':
2382         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2383         break;
2384     case '?':
2385 #ifdef COMPLEX_STATUS
2386         if (PL_localizing == 2) {
2387             PL_statusvalue = LvTARGOFF(sv);
2388             PL_statusvalue_vms = LvTARGLEN(sv);
2389         }
2390         else
2391 #endif
2392 #ifdef VMSISH_STATUS
2393         if (VMSISH_STATUS)
2394             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2395         else
2396 #endif
2397             STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2398         break;
2399     case '!':
2400         {
2401 #ifdef VMS
2402 #   define PERL_VMS_BANG vaxc$errno
2403 #else
2404 #   define PERL_VMS_BANG 0
2405 #endif
2406         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2407                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2408         }
2409         break;
2410     case '<':
2411         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2412         if (PL_delaymagic) {
2413             PL_delaymagic |= DM_RUID;
2414             break;                              /* don't do magic till later */
2415         }
2416 #ifdef HAS_SETRUID
2417         (void)setruid((Uid_t)PL_uid);
2418 #else
2419 #ifdef HAS_SETREUID
2420         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2421 #else
2422 #ifdef HAS_SETRESUID
2423       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2424 #else
2425         if (PL_uid == PL_euid) {                /* special case $< = $> */
2426 #ifdef PERL_DARWIN
2427             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2428             if (PL_uid != 0 && PerlProc_getuid() == 0)
2429                 (void)PerlProc_setuid(0);
2430 #endif
2431             (void)PerlProc_setuid(PL_uid);
2432         } else {
2433             PL_uid = PerlProc_getuid();
2434             Perl_croak(aTHX_ "setruid() not implemented");
2435         }
2436 #endif
2437 #endif
2438 #endif
2439         PL_uid = PerlProc_getuid();
2440         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2441         break;
2442     case '>':
2443         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2444         if (PL_delaymagic) {
2445             PL_delaymagic |= DM_EUID;
2446             break;                              /* don't do magic till later */
2447         }
2448 #ifdef HAS_SETEUID
2449         (void)seteuid((Uid_t)PL_euid);
2450 #else
2451 #ifdef HAS_SETREUID
2452         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2453 #else
2454 #ifdef HAS_SETRESUID
2455         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2456 #else
2457         if (PL_euid == PL_uid)          /* special case $> = $< */
2458             PerlProc_setuid(PL_euid);
2459         else {
2460             PL_euid = PerlProc_geteuid();
2461             Perl_croak(aTHX_ "seteuid() not implemented");
2462         }
2463 #endif
2464 #endif
2465 #endif
2466         PL_euid = PerlProc_geteuid();
2467         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2468         break;
2469     case '(':
2470         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2471         if (PL_delaymagic) {
2472             PL_delaymagic |= DM_RGID;
2473             break;                              /* don't do magic till later */
2474         }
2475 #ifdef HAS_SETRGID
2476         (void)setrgid((Gid_t)PL_gid);
2477 #else
2478 #ifdef HAS_SETREGID
2479         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2480 #else
2481 #ifdef HAS_SETRESGID
2482       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2483 #else
2484         if (PL_gid == PL_egid)                  /* special case $( = $) */
2485             (void)PerlProc_setgid(PL_gid);
2486         else {
2487             PL_gid = PerlProc_getgid();
2488             Perl_croak(aTHX_ "setrgid() not implemented");
2489         }
2490 #endif
2491 #endif
2492 #endif
2493         PL_gid = PerlProc_getgid();
2494         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2495         break;
2496     case ')':
2497 #ifdef HAS_SETGROUPS
2498         {
2499             const char *p = SvPV_const(sv, len);
2500             Groups_t gary[NGROUPS];
2501
2502             while (isSPACE(*p))
2503                 ++p;
2504             PL_egid = Atol(p);
2505             for (i = 0; i < NGROUPS; ++i) {
2506                 while (*p && !isSPACE(*p))
2507                     ++p;
2508                 while (isSPACE(*p))
2509                     ++p;
2510                 if (!*p)
2511                     break;
2512                 gary[i] = Atol(p);
2513             }
2514             if (i)
2515                 (void)setgroups(i, gary);
2516         }
2517 #else  /* HAS_SETGROUPS */
2518         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2519 #endif /* HAS_SETGROUPS */
2520         if (PL_delaymagic) {
2521             PL_delaymagic |= DM_EGID;
2522             break;                              /* don't do magic till later */
2523         }
2524 #ifdef HAS_SETEGID
2525         (void)setegid((Gid_t)PL_egid);
2526 #else
2527 #ifdef HAS_SETREGID
2528         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2529 #else
2530 #ifdef HAS_SETRESGID
2531         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2532 #else
2533         if (PL_egid == PL_gid)                  /* special case $) = $( */
2534             (void)PerlProc_setgid(PL_egid);
2535         else {
2536             PL_egid = PerlProc_getegid();
2537             Perl_croak(aTHX_ "setegid() not implemented");
2538         }
2539 #endif
2540 #endif
2541 #endif
2542         PL_egid = PerlProc_getegid();
2543         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2544         break;
2545     case ':':
2546         PL_chopset = SvPV_force(sv,len);
2547         break;
2548 #ifndef MACOS_TRADITIONAL
2549     case '0':
2550         LOCK_DOLLARZERO_MUTEX;
2551 #ifdef HAS_SETPROCTITLE
2552         /* The BSDs don't show the argv[] in ps(1) output, they
2553          * show a string from the process struct and provide
2554          * the setproctitle() routine to manipulate that. */
2555         {
2556             s = SvPV_const(sv, len);
2557 #   if __FreeBSD_version > 410001
2558             /* The leading "-" removes the "perl: " prefix,
2559              * but not the "(perl) suffix from the ps(1)
2560              * output, because that's what ps(1) shows if the
2561              * argv[] is modified. */
2562             setproctitle("-%s", s);
2563 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2564             /* This doesn't really work if you assume that
2565              * $0 = 'foobar'; will wipe out 'perl' from the $0
2566              * because in ps(1) output the result will be like
2567              * sprintf("perl: %s (perl)", s)
2568              * I guess this is a security feature:
2569              * one (a user process) cannot get rid of the original name.
2570              * --jhi */
2571             setproctitle("%s", s);
2572 #   endif
2573         }
2574 #endif
2575 #if defined(__hpux) && defined(PSTAT_SETCMD)
2576         {
2577              union pstun un;
2578              s = SvPV_const(sv, len);
2579              un.pst_command = (char *)s;
2580              pstat(PSTAT_SETCMD, un, len, 0, 0);
2581         }
2582 #endif
2583         /* PL_origalen is set in perl_parse(). */
2584         s = SvPV_force(sv,len);
2585         if (len >= (STRLEN)PL_origalen-1) {
2586             /* Longer than original, will be truncated. We assume that
2587              * PL_origalen bytes are available. */
2588             Copy(s, PL_origargv[0], PL_origalen-1, char);
2589         }
2590         else {
2591             /* Shorter than original, will be padded. */
2592             Copy(s, PL_origargv[0], len, char);
2593             PL_origargv[0][len] = 0;
2594             memset(PL_origargv[0] + len + 1,
2595                    /* Is the space counterintuitive?  Yes.
2596                     * (You were expecting \0?)
2597                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2598                     * --jhi */
2599                    (int)' ',
2600                    PL_origalen - len - 1);
2601         }
2602         PL_origargv[0][PL_origalen-1] = 0;
2603         for (i = 1; i < PL_origargc; i++)
2604             PL_origargv[i] = 0;
2605         UNLOCK_DOLLARZERO_MUTEX;
2606         break;
2607 #endif
2608     }
2609     return 0;
2610 }
2611
2612 I32
2613 Perl_whichsig(pTHX_ const char *sig)
2614 {
2615     register char* const* sigv;
2616
2617     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2618         if (strEQ(sig,*sigv))
2619             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2620 #ifdef SIGCLD
2621     if (strEQ(sig,"CHLD"))
2622         return SIGCLD;
2623 #endif
2624 #ifdef SIGCHLD
2625     if (strEQ(sig,"CLD"))
2626         return SIGCHLD;
2627 #endif
2628     return -1;
2629 }
2630
2631 Signal_t
2632 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2633 Perl_sighandler(int sig, ...)
2634 #else
2635 Perl_sighandler(int sig)
2636 #endif
2637 {
2638 #ifdef PERL_GET_SIG_CONTEXT
2639     dTHXa(PERL_GET_SIG_CONTEXT);
2640 #else
2641     dTHX;
2642 #endif
2643     dSP;
2644     GV *gv = Nullgv;
2645     SV *sv = Nullsv;
2646     SV * const tSv = PL_Sv;
2647     CV *cv = Nullcv;
2648     OP *myop = PL_op;
2649     U32 flags = 0;
2650     XPV * const tXpv = PL_Xpv;
2651
2652     if (PL_savestack_ix + 15 <= PL_savestack_max)
2653         flags |= 1;
2654     if (PL_markstack_ptr < PL_markstack_max - 2)
2655         flags |= 4;
2656     if (PL_scopestack_ix < PL_scopestack_max - 3)
2657         flags |= 16;
2658
2659     if (!PL_psig_ptr[sig]) {
2660                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2661                                  PL_sig_name[sig]);
2662                 exit(sig);
2663         }
2664
2665     /* Max number of items pushed there is 3*n or 4. We cannot fix
2666        infinity, so we fix 4 (in fact 5): */
2667     if (flags & 1) {
2668         PL_savestack_ix += 5;           /* Protect save in progress. */
2669         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2670     }
2671     if (flags & 4)
2672         PL_markstack_ptr++;             /* Protect mark. */
2673     if (flags & 16)
2674         PL_scopestack_ix += 1;
2675     /* sv_2cv is too complicated, try a simpler variant first: */
2676     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2677         || SvTYPE(cv) != SVt_PVCV) {
2678         HV *st;
2679         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2680     }
2681
2682     if (!cv || !CvROOT(cv)) {
2683         if (ckWARN(WARN_SIGNAL))
2684             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2685                 PL_sig_name[sig], (gv ? GvENAME(gv)
2686                                 : ((cv && CvGV(cv))
2687                                    ? GvENAME(CvGV(cv))
2688                                    : "__ANON__")));
2689         goto cleanup;
2690     }
2691
2692     if(PL_psig_name[sig]) {
2693         sv = SvREFCNT_inc(PL_psig_name[sig]);
2694         flags |= 64;
2695 #if !defined(PERL_IMPLICIT_CONTEXT)
2696         PL_sig_sv = sv;
2697 #endif
2698     } else {
2699         sv = sv_newmortal();
2700         sv_setpv(sv,PL_sig_name[sig]);
2701     }
2702
2703     PUSHSTACKi(PERLSI_SIGNAL);
2704     PUSHMARK(SP);
2705     PUSHs(sv);
2706 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2707     {
2708          struct sigaction oact;
2709
2710          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2711               siginfo_t *sip;
2712               va_list args;
2713
2714               va_start(args, sig);
2715               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2716               if (sip) {
2717                    HV *sih = newHV();
2718                    SV *rv  = newRV_noinc((SV*)sih);
2719                    /* The siginfo fields signo, code, errno, pid, uid,
2720                     * addr, status, and band are defined by POSIX/SUSv3. */
2721                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2722                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2723 #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. */
2724                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2725                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2726                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2727                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2728                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2729                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2730 #endif
2731                    EXTEND(SP, 2);
2732                    PUSHs((SV*)rv);
2733                    PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2734               }
2735          }
2736     }
2737 #endif
2738     PUTBACK;
2739
2740     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2741
2742     POPSTACK;
2743     if (SvTRUE(ERRSV)) {
2744 #ifndef PERL_MICRO
2745 #ifdef HAS_SIGPROCMASK
2746         /* Handler "died", for example to get out of a restart-able read().
2747          * Before we re-do that on its behalf re-enable the signal which was
2748          * blocked by the system when we entered.
2749          */
2750         sigset_t set;
2751         sigemptyset(&set);
2752         sigaddset(&set,sig);
2753         sigprocmask(SIG_UNBLOCK, &set, NULL);
2754 #else
2755         /* Not clear if this will work */
2756         (void)rsignal(sig, SIG_IGN);
2757         (void)rsignal(sig, PL_csighandlerp);
2758 #endif
2759 #endif /* !PERL_MICRO */
2760         Perl_die(aTHX_ Nullch);
2761     }
2762 cleanup:
2763     if (flags & 1)
2764         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2765     if (flags & 4)
2766         PL_markstack_ptr--;
2767     if (flags & 16)
2768         PL_scopestack_ix -= 1;
2769     if (flags & 64)
2770         SvREFCNT_dec(sv);
2771     PL_op = myop;                       /* Apparently not needed... */
2772
2773     PL_Sv = tSv;                        /* Restore global temporaries. */
2774     PL_Xpv = tXpv;
2775     return;
2776 }
2777
2778
2779 static void
2780 S_restore_magic(pTHX_ const void *p)
2781 {
2782     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2783     SV* const sv = mgs->mgs_sv;
2784
2785     if (!sv)
2786         return;
2787
2788     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2789     {
2790 #ifdef PERL_OLD_COPY_ON_WRITE
2791         /* While magic was saved (and off) sv_setsv may well have seen
2792            this SV as a prime candidate for COW.  */
2793         if (SvIsCOW(sv))
2794             sv_force_normal(sv);
2795 #endif
2796
2797         if (mgs->mgs_flags)
2798             SvFLAGS(sv) |= mgs->mgs_flags;
2799         else
2800             mg_magical(sv);
2801         if (SvGMAGICAL(sv)) {
2802             /* downgrade public flags to private,
2803                and discard any other private flags */
2804
2805             U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2806             if (public) {
2807                 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2808                 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2809             }
2810         }
2811     }
2812
2813     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2814
2815     /* If we're still on top of the stack, pop us off.  (That condition
2816      * will be satisfied if restore_magic was called explicitly, but *not*
2817      * if it's being called via leave_scope.)
2818      * The reason for doing this is that otherwise, things like sv_2cv()
2819      * may leave alloc gunk on the savestack, and some code
2820      * (e.g. sighandler) doesn't expect that...
2821      */
2822     if (PL_savestack_ix == mgs->mgs_ss_ix)
2823     {
2824         I32 popval = SSPOPINT;
2825         assert(popval == SAVEt_DESTRUCTOR_X);
2826         PL_savestack_ix -= 2;
2827         popval = SSPOPINT;
2828         assert(popval == SAVEt_ALLOC);
2829         popval = SSPOPINT;
2830         PL_savestack_ix -= popval;
2831     }
2832
2833 }
2834
2835 static void
2836 S_unwind_handler_stack(pTHX_ const void *p)
2837 {
2838     dVAR;
2839     const U32 flags = *(const U32*)p;
2840
2841     if (flags & 1)
2842         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2843     /* cxstack_ix-- Not needed, die already unwound it. */
2844 #if !defined(PERL_IMPLICIT_CONTEXT)
2845     if (flags & 64)
2846         SvREFCNT_dec(PL_sig_sv);
2847 #endif
2848 }
2849
2850 /*
2851  * Local variables:
2852  * c-indentation-style: bsd
2853  * c-basic-offset: 4
2854  * indent-tabs-mode: t
2855  * End:
2856  *
2857  * ex: set ts=8 sts=4 sw=4 noet:
2858  */