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