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