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