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