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