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_IOK|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     const U32 wasfake = SvFLAGS(sv) & SVf_FAKE;
1843     PERL_UNUSED_ARG(mg);
1844
1845     /* FAKE globs can get coerced, so need to turn this off temporarily if it
1846        is on.  */
1847     SvFAKE_off(sv);
1848     gv_efullname3(sv,((GV*)sv), "*");
1849     SvFLAGS(sv) |= wasfake;
1850
1851     return 0;
1852 }
1853
1854 int
1855 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1856 {
1857     GV* gv;
1858     PERL_UNUSED_ARG(mg);
1859
1860     if (!SvOK(sv))
1861         return 0;
1862     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1863     if (sv == (SV*)gv)
1864         return 0;
1865     if (GvGP(sv))
1866         gp_free((GV*)sv);
1867     GvGP(sv) = gp_ref(GvGP(gv));
1868     return 0;
1869 }
1870
1871 int
1872 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1873 {
1874     STRLEN len;
1875     SV * const lsv = LvTARG(sv);
1876     const char * const tmps = SvPV_const(lsv,len);
1877     I32 offs = LvTARGOFF(sv);
1878     I32 rem = LvTARGLEN(sv);
1879     PERL_UNUSED_ARG(mg);
1880
1881     if (SvUTF8(lsv))
1882         sv_pos_u2b(lsv, &offs, &rem);
1883     if (offs > (I32)len)
1884         offs = len;
1885     if (rem + offs > (I32)len)
1886         rem = len - offs;
1887     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1888     if (SvUTF8(lsv))
1889         SvUTF8_on(sv);
1890     return 0;
1891 }
1892
1893 int
1894 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1895 {
1896     dVAR;
1897     STRLEN len;
1898     const char *tmps = SvPV_const(sv, len);
1899     SV * const lsv = LvTARG(sv);
1900     I32 lvoff = LvTARGOFF(sv);
1901     I32 lvlen = LvTARGLEN(sv);
1902     PERL_UNUSED_ARG(mg);
1903
1904     if (DO_UTF8(sv)) {
1905         sv_utf8_upgrade(lsv);
1906         sv_pos_u2b(lsv, &lvoff, &lvlen);
1907         sv_insert(lsv, lvoff, lvlen, tmps, len);
1908         LvTARGLEN(sv) = sv_len_utf8(sv);
1909         SvUTF8_on(lsv);
1910     }
1911     else if (lsv && SvUTF8(lsv)) {
1912         sv_pos_u2b(lsv, &lvoff, &lvlen);
1913         LvTARGLEN(sv) = len;
1914         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1915         sv_insert(lsv, lvoff, lvlen, tmps, len);
1916         Safefree(tmps);
1917     }
1918     else {
1919         sv_insert(lsv, lvoff, lvlen, tmps, len);
1920         LvTARGLEN(sv) = len;
1921     }
1922
1923
1924     return 0;
1925 }
1926
1927 int
1928 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1929 {
1930     dVAR;
1931     PERL_UNUSED_ARG(sv);
1932     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1933     return 0;
1934 }
1935
1936 int
1937 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1938 {
1939     dVAR;
1940     PERL_UNUSED_ARG(sv);
1941     /* update taint status unless we're restoring at scope exit */
1942     if (PL_localizing != 2) {
1943         if (PL_tainted)
1944             mg->mg_len |= 1;
1945         else
1946             mg->mg_len &= ~1;
1947     }
1948     return 0;
1949 }
1950
1951 int
1952 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1953 {
1954     SV * const lsv = LvTARG(sv);
1955     PERL_UNUSED_ARG(mg);
1956
1957     if (lsv)
1958         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1959     else
1960         SvOK_off(sv);
1961
1962     return 0;
1963 }
1964
1965 int
1966 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1967 {
1968     PERL_UNUSED_ARG(mg);
1969     do_vecset(sv);      /* XXX slurp this routine */
1970     return 0;
1971 }
1972
1973 int
1974 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1975 {
1976     dVAR;
1977     SV *targ = NULL;
1978     if (LvTARGLEN(sv)) {
1979         if (mg->mg_obj) {
1980             SV * const ahv = LvTARG(sv);
1981             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1982             if (he)
1983                 targ = HeVAL(he);
1984         }
1985         else {
1986             AV* const av = (AV*)LvTARG(sv);
1987             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1988                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1989         }
1990         if (targ && targ != &PL_sv_undef) {
1991             /* somebody else defined it for us */
1992             SvREFCNT_dec(LvTARG(sv));
1993             LvTARG(sv) = SvREFCNT_inc(targ);
1994             LvTARGLEN(sv) = 0;
1995             SvREFCNT_dec(mg->mg_obj);
1996             mg->mg_obj = NULL;
1997             mg->mg_flags &= ~MGf_REFCOUNTED;
1998         }
1999     }
2000     else
2001         targ = LvTARG(sv);
2002     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2003     return 0;
2004 }
2005
2006 int
2007 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2008 {
2009     PERL_UNUSED_ARG(mg);
2010     if (LvTARGLEN(sv))
2011         vivify_defelem(sv);
2012     if (LvTARG(sv)) {
2013         sv_setsv(LvTARG(sv), sv);
2014         SvSETMAGIC(LvTARG(sv));
2015     }
2016     return 0;
2017 }
2018
2019 void
2020 Perl_vivify_defelem(pTHX_ SV *sv)
2021 {
2022     dVAR;
2023     MAGIC *mg;
2024     SV *value = NULL;
2025
2026     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2027         return;
2028     if (mg->mg_obj) {
2029         SV * const ahv = LvTARG(sv);
2030         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2031         if (he)
2032             value = HeVAL(he);
2033         if (!value || value == &PL_sv_undef)
2034             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2035     }
2036     else {
2037         AV* const av = (AV*)LvTARG(sv);
2038         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2039             LvTARG(sv) = NULL;  /* array can't be extended */
2040         else {
2041             SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2042             if (!svp || (value = *svp) == &PL_sv_undef)
2043                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2044         }
2045     }
2046     (void)SvREFCNT_inc(value);
2047     SvREFCNT_dec(LvTARG(sv));
2048     LvTARG(sv) = value;
2049     LvTARGLEN(sv) = 0;
2050     SvREFCNT_dec(mg->mg_obj);
2051     mg->mg_obj = NULL;
2052     mg->mg_flags &= ~MGf_REFCOUNTED;
2053 }
2054
2055 int
2056 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2057 {
2058     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2059 }
2060
2061 int
2062 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2063 {
2064     mg->mg_len = -1;
2065     SvSCREAM_off(sv);
2066     return 0;
2067 }
2068
2069 int
2070 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2071 {
2072     PERL_UNUSED_ARG(mg);
2073     sv_unmagic(sv, PERL_MAGIC_bm);
2074     SvVALID_off(sv);
2075     return 0;
2076 }
2077
2078 int
2079 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2080 {
2081     PERL_UNUSED_ARG(mg);
2082     sv_unmagic(sv, PERL_MAGIC_fm);
2083     SvCOMPILED_off(sv);
2084     return 0;
2085 }
2086
2087 int
2088 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2089 {
2090     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2091
2092     if (uf && uf->uf_set)
2093         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2094     return 0;
2095 }
2096
2097 int
2098 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2099 {
2100     PERL_UNUSED_ARG(mg);
2101     sv_unmagic(sv, PERL_MAGIC_qr);
2102     return 0;
2103 }
2104
2105 int
2106 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2107 {
2108     dVAR;
2109     regexp * const re = (regexp *)mg->mg_obj;
2110     PERL_UNUSED_ARG(sv);
2111
2112     ReREFCNT_dec(re);
2113     return 0;
2114 }
2115
2116 #ifdef USE_LOCALE_COLLATE
2117 int
2118 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2119 {
2120     /*
2121      * RenE<eacute> Descartes said "I think not."
2122      * and vanished with a faint plop.
2123      */
2124     PERL_UNUSED_ARG(sv);
2125     if (mg->mg_ptr) {
2126         Safefree(mg->mg_ptr);
2127         mg->mg_ptr = NULL;
2128         mg->mg_len = -1;
2129     }
2130     return 0;
2131 }
2132 #endif /* USE_LOCALE_COLLATE */
2133
2134 /* Just clear the UTF-8 cache data. */
2135 int
2136 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2137 {
2138     PERL_UNUSED_ARG(sv);
2139     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2140     mg->mg_ptr = 0;
2141     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2142     return 0;
2143 }
2144
2145 int
2146 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2147 {
2148     dVAR;
2149     register const char *s;
2150     I32 i;
2151     STRLEN len;
2152     switch (*mg->mg_ptr) {
2153     case '\001':        /* ^A */
2154         sv_setsv(PL_bodytarget, sv);
2155         break;
2156     case '\003':        /* ^C */
2157         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2158         break;
2159
2160     case '\004':        /* ^D */
2161 #ifdef DEBUGGING
2162         s = SvPV_nolen_const(sv);
2163         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2164         DEBUG_x(dump_all());
2165 #else
2166         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2167 #endif
2168         break;
2169     case '\005':  /* ^E */
2170         if (*(mg->mg_ptr+1) == '\0') {
2171 #ifdef MACOS_TRADITIONAL
2172             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2173 #else
2174 #  ifdef VMS
2175             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2176 #  else
2177 #    ifdef WIN32
2178             SetLastError( SvIV(sv) );
2179 #    else
2180 #      ifdef OS2
2181             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2182 #      else
2183             /* will anyone ever use this? */
2184             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2185 #      endif
2186 #    endif
2187 #  endif
2188 #endif
2189         }
2190         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2191             if (PL_encoding)
2192                 SvREFCNT_dec(PL_encoding);
2193             if (SvOK(sv) || SvGMAGICAL(sv)) {
2194                 PL_encoding = newSVsv(sv);
2195             }
2196             else {
2197                 PL_encoding = NULL;
2198             }
2199         }
2200         break;
2201     case '\006':        /* ^F */
2202         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2203         break;
2204     case '\010':        /* ^H */
2205         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2206         break;
2207     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2208         Safefree(PL_inplace);
2209         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2210         break;
2211     case '\017':        /* ^O */
2212         if (*(mg->mg_ptr+1) == '\0') {
2213             Safefree(PL_osname);
2214             PL_osname = NULL;
2215             if (SvOK(sv)) {
2216                 TAINT_PROPER("assigning to $^O");
2217                 PL_osname = savesvpv(sv);
2218             }
2219         }
2220         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2221             if (!PL_compiling.cop_io)
2222                 PL_compiling.cop_io = newSVsv(sv);
2223             else
2224                 sv_setsv(PL_compiling.cop_io,sv);
2225         }
2226         break;
2227     case '\020':        /* ^P */
2228         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2229         if (PL_perldb && !PL_DBsingle)
2230             init_debugger();
2231         break;
2232     case '\024':        /* ^T */
2233 #ifdef BIG_TIME
2234         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2235 #else
2236         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2237 #endif
2238         break;
2239     case '\027':        /* ^W & $^WARNING_BITS */
2240         if (*(mg->mg_ptr+1) == '\0') {
2241             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2242                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2243                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2244                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2245             }
2246         }
2247         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2248             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2249                 if (!SvPOK(sv) && PL_localizing) {
2250                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2251                     PL_compiling.cop_warnings = pWARN_NONE;
2252                     break;
2253                 }
2254                 {
2255                     STRLEN len, i;
2256                     int accumulate = 0 ;
2257                     int any_fatals = 0 ;
2258                     const char * const ptr = SvPV_const(sv, len) ;
2259                     for (i = 0 ; i < len ; ++i) {
2260                         accumulate |= ptr[i] ;
2261                         any_fatals |= (ptr[i] & 0xAA) ;
2262                     }
2263                     if (!accumulate)
2264                         PL_compiling.cop_warnings = pWARN_NONE;
2265                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2266                         PL_compiling.cop_warnings = pWARN_ALL;
2267                         PL_dowarn |= G_WARN_ONCE ;
2268                     }
2269                     else {
2270                         if (specialWARN(PL_compiling.cop_warnings))
2271                             PL_compiling.cop_warnings = newSVsv(sv) ;
2272                         else
2273                             sv_setsv(PL_compiling.cop_warnings, sv);
2274                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2275                             PL_dowarn |= G_WARN_ONCE ;
2276                     }
2277
2278                 }
2279             }
2280         }
2281         break;
2282     case '.':
2283         if (PL_localizing) {
2284             if (PL_localizing == 1)
2285                 SAVESPTR(PL_last_in_gv);
2286         }
2287         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2288             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2289         break;
2290     case '^':
2291         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2292         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2293         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2294         break;
2295     case '~':
2296         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2297         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2298         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2299         break;
2300     case '=':
2301         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2302         break;
2303     case '-':
2304         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2305         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2306             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2307         break;
2308     case '%':
2309         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2310         break;
2311     case '|':
2312         {
2313             IO * const io = GvIOp(PL_defoutgv);
2314             if(!io)
2315               break;
2316             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2317                 IoFLAGS(io) &= ~IOf_FLUSH;
2318             else {
2319                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2320                     PerlIO *ofp = IoOFP(io);
2321                     if (ofp)
2322                         (void)PerlIO_flush(ofp);
2323                     IoFLAGS(io) |= IOf_FLUSH;
2324                 }
2325             }
2326         }
2327         break;
2328     case '/':
2329         SvREFCNT_dec(PL_rs);
2330         PL_rs = newSVsv(sv);
2331         break;
2332     case '\\':
2333         if (PL_ors_sv)
2334             SvREFCNT_dec(PL_ors_sv);
2335         if (SvOK(sv) || SvGMAGICAL(sv)) {
2336             PL_ors_sv = newSVsv(sv);
2337         }
2338         else {
2339             PL_ors_sv = NULL;
2340         }
2341         break;
2342     case ',':
2343         if (PL_ofs_sv)
2344             SvREFCNT_dec(PL_ofs_sv);
2345         if (SvOK(sv) || SvGMAGICAL(sv)) {
2346             PL_ofs_sv = newSVsv(sv);
2347         }
2348         else {
2349             PL_ofs_sv = NULL;
2350         }
2351         break;
2352     case '[':
2353         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2354         break;
2355     case '?':
2356 #ifdef COMPLEX_STATUS
2357         if (PL_localizing == 2) {
2358             PL_statusvalue = LvTARGOFF(sv);
2359             PL_statusvalue_vms = LvTARGLEN(sv);
2360         }
2361         else
2362 #endif
2363 #ifdef VMSISH_STATUS
2364         if (VMSISH_STATUS)
2365             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2366         else
2367 #endif
2368             STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2369         break;
2370     case '!':
2371         {
2372 #ifdef VMS
2373 #   define PERL_VMS_BANG vaxc$errno
2374 #else
2375 #   define PERL_VMS_BANG 0
2376 #endif
2377         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2378                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2379         }
2380         break;
2381     case '<':
2382         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2383         if (PL_delaymagic) {
2384             PL_delaymagic |= DM_RUID;
2385             break;                              /* don't do magic till later */
2386         }
2387 #ifdef HAS_SETRUID
2388         (void)setruid((Uid_t)PL_uid);
2389 #else
2390 #ifdef HAS_SETREUID
2391         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2392 #else
2393 #ifdef HAS_SETRESUID
2394       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2395 #else
2396         if (PL_uid == PL_euid) {                /* special case $< = $> */
2397 #ifdef PERL_DARWIN
2398             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2399             if (PL_uid != 0 && PerlProc_getuid() == 0)
2400                 (void)PerlProc_setuid(0);
2401 #endif
2402             (void)PerlProc_setuid(PL_uid);
2403         } else {
2404             PL_uid = PerlProc_getuid();
2405             Perl_croak(aTHX_ "setruid() not implemented");
2406         }
2407 #endif
2408 #endif
2409 #endif
2410         PL_uid = PerlProc_getuid();
2411         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2412         break;
2413     case '>':
2414         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2415         if (PL_delaymagic) {
2416             PL_delaymagic |= DM_EUID;
2417             break;                              /* don't do magic till later */
2418         }
2419 #ifdef HAS_SETEUID
2420         (void)seteuid((Uid_t)PL_euid);
2421 #else
2422 #ifdef HAS_SETREUID
2423         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2424 #else
2425 #ifdef HAS_SETRESUID
2426         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2427 #else
2428         if (PL_euid == PL_uid)          /* special case $> = $< */
2429             PerlProc_setuid(PL_euid);
2430         else {
2431             PL_euid = PerlProc_geteuid();
2432             Perl_croak(aTHX_ "seteuid() not implemented");
2433         }
2434 #endif
2435 #endif
2436 #endif
2437         PL_euid = PerlProc_geteuid();
2438         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2439         break;
2440     case '(':
2441         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2442         if (PL_delaymagic) {
2443             PL_delaymagic |= DM_RGID;
2444             break;                              /* don't do magic till later */
2445         }
2446 #ifdef HAS_SETRGID
2447         (void)setrgid((Gid_t)PL_gid);
2448 #else
2449 #ifdef HAS_SETREGID
2450         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2451 #else
2452 #ifdef HAS_SETRESGID
2453       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2454 #else
2455         if (PL_gid == PL_egid)                  /* special case $( = $) */
2456             (void)PerlProc_setgid(PL_gid);
2457         else {
2458             PL_gid = PerlProc_getgid();
2459             Perl_croak(aTHX_ "setrgid() not implemented");
2460         }
2461 #endif
2462 #endif
2463 #endif
2464         PL_gid = PerlProc_getgid();
2465         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2466         break;
2467     case ')':
2468 #ifdef HAS_SETGROUPS
2469         {
2470             const char *p = SvPV_const(sv, len);
2471             Groups_t *gary = NULL;
2472
2473             while (isSPACE(*p))
2474                 ++p;
2475             PL_egid = Atol(p);
2476             for (i = 0; i < NGROUPS; ++i) {
2477                 while (*p && !isSPACE(*p))
2478                     ++p;
2479                 while (isSPACE(*p))
2480                     ++p;
2481                 if (!*p)
2482                     break;
2483                 if(!gary)
2484                     Newx(gary, i + 1, Groups_t);
2485                 else
2486                     Renew(gary, i + 1, Groups_t);
2487                 gary[i] = Atol(p);
2488             }
2489             if (i)
2490                 (void)setgroups(i, gary);
2491             if (gary)
2492                 Safefree(gary);
2493         }
2494 #else  /* HAS_SETGROUPS */
2495         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2496 #endif /* HAS_SETGROUPS */
2497         if (PL_delaymagic) {
2498             PL_delaymagic |= DM_EGID;
2499             break;                              /* don't do magic till later */
2500         }
2501 #ifdef HAS_SETEGID
2502         (void)setegid((Gid_t)PL_egid);
2503 #else
2504 #ifdef HAS_SETREGID
2505         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2506 #else
2507 #ifdef HAS_SETRESGID
2508         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2509 #else
2510         if (PL_egid == PL_gid)                  /* special case $) = $( */
2511             (void)PerlProc_setgid(PL_egid);
2512         else {
2513             PL_egid = PerlProc_getegid();
2514             Perl_croak(aTHX_ "setegid() not implemented");
2515         }
2516 #endif
2517 #endif
2518 #endif
2519         PL_egid = PerlProc_getegid();
2520         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2521         break;
2522     case ':':
2523         PL_chopset = SvPV_force(sv,len);
2524         break;
2525 #ifndef MACOS_TRADITIONAL
2526     case '0':
2527         LOCK_DOLLARZERO_MUTEX;
2528 #ifdef HAS_SETPROCTITLE
2529         /* The BSDs don't show the argv[] in ps(1) output, they
2530          * show a string from the process struct and provide
2531          * the setproctitle() routine to manipulate that. */
2532         if (PL_origalen != 1) {
2533             s = SvPV_const(sv, len);
2534 #   if __FreeBSD_version > 410001
2535             /* The leading "-" removes the "perl: " prefix,
2536              * but not the "(perl) suffix from the ps(1)
2537              * output, because that's what ps(1) shows if the
2538              * argv[] is modified. */
2539             setproctitle("-%s", s);
2540 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2541             /* This doesn't really work if you assume that
2542              * $0 = 'foobar'; will wipe out 'perl' from the $0
2543              * because in ps(1) output the result will be like
2544              * sprintf("perl: %s (perl)", s)
2545              * I guess this is a security feature:
2546              * one (a user process) cannot get rid of the original name.
2547              * --jhi */
2548             setproctitle("%s", s);
2549 #   endif
2550         }
2551 #endif
2552 #if defined(__hpux) && defined(PSTAT_SETCMD)
2553         if (PL_origalen != 1) {
2554              union pstun un;
2555              s = SvPV_const(sv, len);
2556              un.pst_command = (char *)s;
2557              pstat(PSTAT_SETCMD, un, len, 0, 0);
2558         }
2559 #endif
2560         if (PL_origalen > 1) {
2561             /* PL_origalen is set in perl_parse(). */
2562             s = SvPV_force(sv,len);
2563             if (len >= (STRLEN)PL_origalen-1) {
2564                 /* Longer than original, will be truncated. We assume that
2565                  * PL_origalen bytes are available. */
2566                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2567             }
2568             else {
2569                 /* Shorter than original, will be padded. */
2570                 Copy(s, PL_origargv[0], len, char);
2571                 PL_origargv[0][len] = 0;
2572                 memset(PL_origargv[0] + len + 1,
2573                        /* Is the space counterintuitive?  Yes.
2574                         * (You were expecting \0?)
2575                         * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2576                         * --jhi */
2577                        (int)' ',
2578                        PL_origalen - len - 1);
2579             }
2580             PL_origargv[0][PL_origalen-1] = 0;
2581             for (i = 1; i < PL_origargc; i++)
2582                 PL_origargv[i] = 0;
2583         }
2584         UNLOCK_DOLLARZERO_MUTEX;
2585         break;
2586 #endif
2587     }
2588     return 0;
2589 }
2590
2591 I32
2592 Perl_whichsig(pTHX_ const char *sig)
2593 {
2594     register char* const* sigv;
2595
2596     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2597         if (strEQ(sig,*sigv))
2598             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2599 #ifdef SIGCLD
2600     if (strEQ(sig,"CHLD"))
2601         return SIGCLD;
2602 #endif
2603 #ifdef SIGCHLD
2604     if (strEQ(sig,"CLD"))
2605         return SIGCHLD;
2606 #endif
2607     return -1;
2608 }
2609
2610 Signal_t
2611 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2612 Perl_sighandler(int sig, ...)
2613 #else
2614 Perl_sighandler(int sig)
2615 #endif
2616 {
2617 #ifdef PERL_GET_SIG_CONTEXT
2618     dTHXa(PERL_GET_SIG_CONTEXT);
2619 #else
2620     dTHX;
2621 #endif
2622     dSP;
2623     GV *gv = NULL;
2624     SV *sv = NULL;
2625     SV * const tSv = PL_Sv;
2626     CV *cv = NULL;
2627     OP *myop = PL_op;
2628     U32 flags = 0;
2629     XPV * const tXpv = PL_Xpv;
2630
2631     if (PL_savestack_ix + 15 <= PL_savestack_max)
2632         flags |= 1;
2633     if (PL_markstack_ptr < PL_markstack_max - 2)
2634         flags |= 4;
2635     if (PL_scopestack_ix < PL_scopestack_max - 3)
2636         flags |= 16;
2637
2638     if (!PL_psig_ptr[sig]) {
2639                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2640                                  PL_sig_name[sig]);
2641                 exit(sig);
2642         }
2643
2644     /* Max number of items pushed there is 3*n or 4. We cannot fix
2645        infinity, so we fix 4 (in fact 5): */
2646     if (flags & 1) {
2647         PL_savestack_ix += 5;           /* Protect save in progress. */
2648         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2649     }
2650     if (flags & 4)
2651         PL_markstack_ptr++;             /* Protect mark. */
2652     if (flags & 16)
2653         PL_scopestack_ix += 1;
2654     /* sv_2cv is too complicated, try a simpler variant first: */
2655     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2656         || SvTYPE(cv) != SVt_PVCV) {
2657         HV *st;
2658         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2659     }
2660
2661     if (!cv || !CvROOT(cv)) {
2662         if (ckWARN(WARN_SIGNAL))
2663             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2664                 PL_sig_name[sig], (gv ? GvENAME(gv)
2665                                 : ((cv && CvGV(cv))
2666                                    ? GvENAME(CvGV(cv))
2667                                    : "__ANON__")));
2668         goto cleanup;
2669     }
2670
2671     if(PL_psig_name[sig]) {
2672         sv = SvREFCNT_inc(PL_psig_name[sig]);
2673         flags |= 64;
2674 #if !defined(PERL_IMPLICIT_CONTEXT)
2675         PL_sig_sv = sv;
2676 #endif
2677     } else {
2678         sv = sv_newmortal();
2679         sv_setpv(sv,PL_sig_name[sig]);
2680     }
2681
2682     PUSHSTACKi(PERLSI_SIGNAL);
2683     PUSHMARK(SP);
2684     PUSHs(sv);
2685 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2686     {
2687          struct sigaction oact;
2688
2689          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2690               siginfo_t *sip;
2691               va_list args;
2692
2693               va_start(args, sig);
2694               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2695               if (sip) {
2696                    HV *sih = newHV();
2697                    SV *rv  = newRV_noinc((SV*)sih);
2698                    /* The siginfo fields signo, code, errno, pid, uid,
2699                     * addr, status, and band are defined by POSIX/SUSv3. */
2700                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2701                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2702 #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. */
2703                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2704                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2705                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2706                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2707                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2708                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2709 #endif
2710                    EXTEND(SP, 2);
2711                    PUSHs((SV*)rv);
2712                    PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2713               }
2714
2715               va_end(args);
2716          }
2717     }
2718 #endif
2719     PUTBACK;
2720
2721     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2722
2723     POPSTACK;
2724     if (SvTRUE(ERRSV)) {
2725 #ifndef PERL_MICRO
2726 #ifdef HAS_SIGPROCMASK
2727         /* Handler "died", for example to get out of a restart-able read().
2728          * Before we re-do that on its behalf re-enable the signal which was
2729          * blocked by the system when we entered.
2730          */
2731         sigset_t set;
2732         sigemptyset(&set);
2733         sigaddset(&set,sig);
2734         sigprocmask(SIG_UNBLOCK, &set, NULL);
2735 #else
2736         /* Not clear if this will work */
2737         (void)rsignal(sig, SIG_IGN);
2738         (void)rsignal(sig, PL_csighandlerp);
2739 #endif
2740 #endif /* !PERL_MICRO */
2741         Perl_die(aTHX_ NULL);
2742     }
2743 cleanup:
2744     if (flags & 1)
2745         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2746     if (flags & 4)
2747         PL_markstack_ptr--;
2748     if (flags & 16)
2749         PL_scopestack_ix -= 1;
2750     if (flags & 64)
2751         SvREFCNT_dec(sv);
2752     PL_op = myop;                       /* Apparently not needed... */
2753
2754     PL_Sv = tSv;                        /* Restore global temporaries. */
2755     PL_Xpv = tXpv;
2756     return;
2757 }
2758
2759
2760 static void
2761 S_restore_magic(pTHX_ const void *p)
2762 {
2763     dVAR;
2764     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2765     SV* const sv = mgs->mgs_sv;
2766
2767     if (!sv)
2768         return;
2769
2770     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2771     {
2772 #ifdef PERL_OLD_COPY_ON_WRITE
2773         /* While magic was saved (and off) sv_setsv may well have seen
2774            this SV as a prime candidate for COW.  */
2775         if (SvIsCOW(sv))
2776             sv_force_normal_flags(sv, 0);
2777 #endif
2778
2779         if (mgs->mgs_flags)
2780             SvFLAGS(sv) |= mgs->mgs_flags;
2781         else
2782             mg_magical(sv);
2783         if (SvGMAGICAL(sv)) {
2784             /* downgrade public flags to private,
2785                and discard any other private flags */
2786
2787             U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2788             if (public) {
2789                 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2790                 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2791             }
2792         }
2793     }
2794
2795     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2796
2797     /* If we're still on top of the stack, pop us off.  (That condition
2798      * will be satisfied if restore_magic was called explicitly, but *not*
2799      * if it's being called via leave_scope.)
2800      * The reason for doing this is that otherwise, things like sv_2cv()
2801      * may leave alloc gunk on the savestack, and some code
2802      * (e.g. sighandler) doesn't expect that...
2803      */
2804     if (PL_savestack_ix == mgs->mgs_ss_ix)
2805     {
2806         I32 popval = SSPOPINT;
2807         assert(popval == SAVEt_DESTRUCTOR_X);
2808         PL_savestack_ix -= 2;
2809         popval = SSPOPINT;
2810         assert(popval == SAVEt_ALLOC);
2811         popval = SSPOPINT;
2812         PL_savestack_ix -= popval;
2813     }
2814
2815 }
2816
2817 static void
2818 S_unwind_handler_stack(pTHX_ const void *p)
2819 {
2820     dVAR;
2821     const U32 flags = *(const U32*)p;
2822
2823     if (flags & 1)
2824         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2825 #if !defined(PERL_IMPLICIT_CONTEXT)
2826     if (flags & 64)
2827         SvREFCNT_dec(PL_sig_sv);
2828 #endif
2829 }
2830
2831 /*
2832  * Local variables:
2833  * c-indentation-style: bsd
2834  * c-basic-offset: 4
2835  * indent-tabs-mode: t
2836  * End:
2837  *
2838  * ex: set ts=8 sts=4 sw=4 noet:
2839  */