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 0;
 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                 if (!rx->subbeg)
 847                     break;
 848
 849               getrx:
 850                 if (i >= 0) {
 851                     const int oldtainted = PL_tainted;
 852                     TAINT_NOT;
 853                     sv_setpvn(sv, s, i);
 854                     PL_tainted = oldtainted;
 855                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 856                         SvUTF8_on(sv);
 857                     else
 858                         SvUTF8_off(sv);
 859                     if (PL_tainting) {
 860                         if (RX_MATCH_TAINTED(rx)) {
 861                             MAGIC* const mg = SvMAGIC(sv);
 862                             MAGIC* mgt;
 863                             PL_tainted = 1;
 864                             SvMAGIC_set(sv, mg->mg_moremagic);
 865                             SvTAINT(sv);
 866                             if ((mgt = SvMAGIC(sv))) {
 867                                 mg->mg_moremagic = mgt;
 868                                 SvMAGIC_set(sv, mg);
 869                             }
 870                         } else
 871                             SvTAINTED_off(sv);
 872                     }
 873                     break;
 874                 }
 875             }
 876         }
 877         sv_setsv(sv,&PL_sv_undef);
 878         break;
 879     case '+':
 880         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 881             paren = rx->lastparen;
 882             if (paren)
 883                 goto getparen;
 884         }
 885         sv_setsv(sv,&PL_sv_undef);
 886         break;
 887     case '\016':                /* ^N */
 888         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 889             paren = rx->lastcloseparen;
 890             if (paren)
 891                 goto getparen;
 892         }
 893         sv_setsv(sv,&PL_sv_undef);
 894         break;
 895     case '`':
 896         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 897             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 898                 i = rx->startp[0];
 899                 goto getrx;
 900             }
 901         }
 902         sv_setsv(sv,&PL_sv_undef);
 903         break;
 904     case '\'':
 905         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 906             if (rx->subbeg && rx->endp[0] != -1) {
 907                 s = rx->subbeg + rx->endp[0];
 908                 i = rx->sublen - rx->endp[0];
 909                 goto getrx;
 910             }
 911         }
 912         sv_setsv(sv,&PL_sv_undef);
 913         break;
 914     case '.':
 915         if (GvIO(PL_last_in_gv)) {
 916             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 917         }
 918         break;
 919     case '?':
 920         {
 921             sv_setiv(sv, (IV)STATUS_CURRENT);
 922 #ifdef COMPLEX_STATUS
 923             LvTARGOFF(sv) = PL_statusvalue;
 924             LvTARGLEN(sv) = PL_statusvalue_vms;
 925 #endif
 926         }
 927         break;
 928     case '^':
 929         if (GvIOp(PL_defoutgv))
 930             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 931         if (s)
 932             sv_setpv(sv,s);
 933         else {
 934             sv_setpv(sv,GvENAME(PL_defoutgv));
 935             sv_catpv(sv,"_TOP");
 936         }
 937         break;
 938     case '~':
 939         if (GvIOp(PL_defoutgv))
 940             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 941         if (!s)
 942             s = GvENAME(PL_defoutgv);
 943         sv_setpv(sv,s);
 944         break;
 945     case '=':
 946         if (GvIOp(PL_defoutgv))
 947             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 948         break;
 949     case '-':
 950         if (GvIOp(PL_defoutgv))
 951             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 952         break;
 953     case '%':
 954         if (GvIOp(PL_defoutgv))
 955             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 956         break;
 957     case ':':
 958         break;
 959     case '/':
 960         break;
 961     case '[':
 962         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 963         break;
 964     case '|':
 965         if (GvIOp(PL_defoutgv))
 966             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 967         break;
 968     case ',':
 969         break;
 970     case '\\':
 971         if (PL_ors_sv)
 972             sv_copypv(sv, PL_ors_sv);
 973         break;
 974     case '!':
 975 #ifdef VMS
 976         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 977         sv_setpv(sv, errno ? Strerror(errno) : "");
 978 #else
 979         {
 980         const int saveerrno = errno;
 981         sv_setnv(sv, (NV)errno);
 982 #ifdef OS2
 983         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 984             sv_setpv(sv, os2error(Perl_rc));
 985         else
 986 #endif
 987         sv_setpv(sv, errno ? Strerror(errno) : "");
 988         errno = saveerrno;
 989         }
 990 #endif
 991         SvRTRIM(sv);
 992         SvNOK_on(sv);   /* what a wonderful hack! */
 993         break;
 994     case '<':
 995         sv_setiv(sv, (IV)PL_uid);
 996         break;
 997     case '>':
 998         sv_setiv(sv, (IV)PL_euid);
 999         break;
1000     case '(':
1001         sv_setiv(sv, (IV)PL_gid);
1002         goto add_groups;
1003     case ')':
1004         sv_setiv(sv, (IV)PL_egid);
1005       add_groups:
1006 #ifdef HAS_GETGROUPS
1007         {
1008             Groups_t *gary = NULL;
1009             I32 i, num_groups = getgroups(0, gary);
1010             Newx(gary, num_groups, Groups_t);
1011             num_groups = getgroups(num_groups, gary);
1012             for (i = 0; i < num_groups; i++)
1013                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1014             Safefree(gary);
1015         }
1016         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1017 #endif
1018         break;
1019 #ifndef MACOS_TRADITIONAL
1020     case '0':
1021         break;
1022 #endif
1023     }
1024     return 0;
1025 }
1026
1027 int
1028 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1029 {
1030     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1031
1032     if (uf && uf->uf_val)
1033         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1034     return 0;
1035 }
1036
1037 int
1038 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1039 {
1040     dVAR;
1041     STRLEN len, klen;
1042     const char *s = SvPV_const(sv,len);
1043     const char * const ptr = MgPV_const(mg,klen);
1044     my_setenv(ptr, s);
1045
1046 #ifdef DYNAMIC_ENV_FETCH
1047      /* We just undefd an environment var.  Is a replacement */
1048      /* waiting in the wings? */
1049     if (!len) {
1050         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1051         if (valp)
1052             s = SvPV_const(*valp, len);
1053     }
1054 #endif
1055
1056 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1057                             /* And you'll never guess what the dog had */
1058                             /*   in its mouth... */
1059     if (PL_tainting) {
1060         MgTAINTEDDIR_off(mg);
1061 #ifdef VMS
1062         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1063             char pathbuf[256], eltbuf[256], *cp, *elt;
1064             Stat_t sbuf;
1065             int i = 0, j = 0;
1066
1067             strncpy(eltbuf, s, 255);
1068             eltbuf[255] = 0;
1069             elt = eltbuf;
1070             do {          /* DCL$PATH may be a search list */
1071                 while (1) {   /* as may dev portion of any element */
1072                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1073                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1074                              cando_by_name(S_IWUSR,0,elt) ) {
1075                             MgTAINTEDDIR_on(mg);
1076                             return 0;
1077                         }
1078                     }
1079                     if ((cp = strchr(elt, ':')) != Nullch)
1080                         *cp = '\0';
1081                     if (my_trnlnm(elt, eltbuf, j++))
1082                         elt = eltbuf;
1083                     else
1084                         break;
1085                 }
1086                 j = 0;
1087             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1088         }
1089 #endif /* VMS */
1090         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1091             const char * const strend = s + len;
1092
1093             while (s < strend) {
1094                 char tmpbuf[256];
1095                 Stat_t st;
1096                 I32 i;
1097                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1098                              s, strend, ':', &i);
1099                 s++;
1100                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1101                       || *tmpbuf != '/'
1102                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1103                     MgTAINTEDDIR_on(mg);
1104                     return 0;
1105                 }
1106             }
1107         }
1108     }
1109 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1110
1111     return 0;
1112 }
1113
1114 int
1115 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1116 {
1117     PERL_UNUSED_ARG(sv);
1118     my_setenv(MgPV_nolen_const(mg),Nullch);
1119     return 0;
1120 }
1121
1122 int
1123 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1124 {
1125     dVAR;
1126     PERL_UNUSED_ARG(mg);
1127 #if defined(VMS)
1128     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1129 #else
1130     if (PL_localizing) {
1131         HE* entry;
1132         my_clearenv();
1133         hv_iterinit((HV*)sv);
1134         while ((entry = hv_iternext((HV*)sv))) {
1135             I32 keylen;
1136             my_setenv(hv_iterkey(entry, &keylen),
1137                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1138         }
1139     }
1140 #endif
1141     return 0;
1142 }
1143
1144 int
1145 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1146 {
1147     dVAR;
1148     PERL_UNUSED_ARG(sv);
1149     PERL_UNUSED_ARG(mg);
1150 #if defined(VMS)
1151     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1152 #else
1153     my_clearenv();
1154 #endif
1155     return 0;
1156 }
1157
1158 #ifndef PERL_MICRO
1159 #ifdef HAS_SIGPROCMASK
1160 static void
1161 restore_sigmask(pTHX_ SV *save_sv)
1162 {
1163     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1164     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1165 }
1166 #endif
1167 int
1168 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1169 {
1170     dVAR;
1171     /* Are we fetching a signal entry? */
1172     const I32 i = whichsig(MgPV_nolen_const(mg));
1173     if (i > 0) {
1174         if(PL_psig_ptr[i])
1175             sv_setsv(sv,PL_psig_ptr[i]);
1176         else {
1177             Sighandler_t sigstate;
1178             sigstate = rsignal_state(i);
1179 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1180             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1181 #endif
1182 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1183             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1184 #endif
1185             /* cache state so we don't fetch it again */
1186             if(sigstate == (Sighandler_t) SIG_IGN)
1187                 sv_setpv(sv,"IGNORE");
1188             else
1189                 sv_setsv(sv,&PL_sv_undef);
1190             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1191             SvTEMP_off(sv);
1192         }
1193     }
1194     return 0;
1195 }
1196 int
1197 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1198 {
1199     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1200      * refactoring might be in order.
1201      */
1202     dVAR;
1203     register const char * const s = MgPV_nolen_const(mg);
1204     PERL_UNUSED_ARG(sv);
1205     if (*s == '_') {
1206         SV** svp = NULL;
1207         if (strEQ(s,"__DIE__"))
1208             svp = &PL_diehook;
1209         else if (strEQ(s,"__WARN__"))
1210             svp = &PL_warnhook;
1211         else
1212             Perl_croak(aTHX_ "No such hook: %s", s);
1213         if (svp && *svp) {
1214             SV * const to_dec = *svp;
1215             *svp = NULL;
1216             SvREFCNT_dec(to_dec);
1217         }
1218     }
1219     else {
1220         /* Are we clearing a signal entry? */
1221         const I32 i = whichsig(s);
1222         if (i > 0) {
1223 #ifdef HAS_SIGPROCMASK
1224             sigset_t set, save;
1225             SV* save_sv;
1226             /* Avoid having the signal arrive at a bad time, if possible. */
1227             sigemptyset(&set);
1228             sigaddset(&set,i);
1229             sigprocmask(SIG_BLOCK, &set, &save);
1230             ENTER;
1231             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1232             SAVEFREESV(save_sv);
1233             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1234 #endif
1235             PERL_ASYNC_CHECK();
1236 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1237             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1238 #endif
1239 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1240             PL_sig_defaulting[i] = 1;
1241             (void)rsignal(i, PL_csighandlerp);
1242 #else
1243             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1244 #endif
1245             if(PL_psig_name[i]) {
1246                 SvREFCNT_dec(PL_psig_name[i]);
1247                 PL_psig_name[i]=0;
1248             }
1249             if(PL_psig_ptr[i]) {
1250                 SV * const to_dec=PL_psig_ptr[i];
1251                 PL_psig_ptr[i]=0;
1252                 LEAVE;
1253                 SvREFCNT_dec(to_dec);
1254             }
1255             else
1256                 LEAVE;
1257         }
1258     }
1259     return 0;
1260 }
1261
1262 static void
1263 S_raise_signal(pTHX_ int sig)
1264 {
1265     dVAR;
1266     /* Set a flag to say this signal is pending */
1267     PL_psig_pend[sig]++;
1268     /* And one to say _a_ signal is pending */
1269     PL_sig_pending = 1;
1270 }
1271
1272 Signal_t
1273 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1274 Perl_csighandler(int sig, ...)
1275 #else
1276 Perl_csighandler(int sig)
1277 #endif
1278 {
1279 #ifdef PERL_GET_SIG_CONTEXT
1280     dTHXa(PERL_GET_SIG_CONTEXT);
1281 #else
1282     dTHX;
1283 #endif
1284 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1285     (void) rsignal(sig, PL_csighandlerp);
1286     if (PL_sig_ignoring[sig]) return;
1287 #endif
1288 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1289     if (PL_sig_defaulting[sig])
1290 #ifdef KILL_BY_SIGPRC
1291             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1292 #else
1293             exit(1);
1294 #endif
1295 #endif
1296    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1297         /* Call the perl level handler now--
1298          * with risk we may be in malloc() etc. */
1299         (*PL_sighandlerp)(sig);
1300    else
1301         S_raise_signal(aTHX_ sig);
1302 }
1303
1304 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1305 void
1306 Perl_csighandler_init(void)
1307 {
1308     int sig;
1309     if (PL_sig_handlers_initted) return;
1310
1311     for (sig = 1; sig < SIG_SIZE; sig++) {
1312 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1313         dTHX;
1314         PL_sig_defaulting[sig] = 1;
1315         (void) rsignal(sig, PL_csighandlerp);
1316 #endif
1317 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1318         PL_sig_ignoring[sig] = 0;
1319 #endif
1320     }
1321     PL_sig_handlers_initted = 1;
1322 }
1323 #endif
1324
1325 void
1326 Perl_despatch_signals(pTHX)
1327 {
1328     dVAR;
1329     int sig;
1330     PL_sig_pending = 0;
1331     for (sig = 1; sig < SIG_SIZE; sig++) {
1332         if (PL_psig_pend[sig]) {
1333             PERL_BLOCKSIG_ADD(set, sig);
1334             PL_psig_pend[sig] = 0;
1335             PERL_BLOCKSIG_BLOCK(set);
1336             (*PL_sighandlerp)(sig);
1337             PERL_BLOCKSIG_UNBLOCK(set);
1338         }
1339     }
1340 }
1341
1342 int
1343 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1344 {
1345     dVAR;
1346     I32 i;
1347     SV** svp = NULL;
1348     /* Need to be careful with SvREFCNT_dec(), because that can have side
1349      * effects (due to closures). We must make sure that the new disposition
1350      * is in place before it is called.
1351      */
1352     SV* to_dec = NULL;
1353     STRLEN len;
1354 #ifdef HAS_SIGPROCMASK
1355     sigset_t set, save;
1356     SV* save_sv;
1357 #endif
1358
1359     register const char *s = MgPV_const(mg,len);
1360     if (*s == '_') {
1361         if (strEQ(s,"__DIE__"))
1362             svp = &PL_diehook;
1363         else if (strEQ(s,"__WARN__"))
1364             svp = &PL_warnhook;
1365         else
1366             Perl_croak(aTHX_ "No such hook: %s", s);
1367         i = 0;
1368         if (*svp) {
1369             to_dec = *svp;
1370             *svp = NULL;
1371         }
1372     }
1373     else {
1374         i = whichsig(s);        /* ...no, a brick */
1375         if (i <= 0) {
1376             if (ckWARN(WARN_SIGNAL))
1377                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1378             return 0;
1379         }
1380 #ifdef HAS_SIGPROCMASK
1381         /* Avoid having the signal arrive at a bad time, if possible. */
1382         sigemptyset(&set);
1383         sigaddset(&set,i);
1384         sigprocmask(SIG_BLOCK, &set, &save);
1385         ENTER;
1386         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1387         SAVEFREESV(save_sv);
1388         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1389 #endif
1390         PERL_ASYNC_CHECK();
1391 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1392         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1393 #endif
1394 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1395         PL_sig_ignoring[i] = 0;
1396 #endif
1397 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1398         PL_sig_defaulting[i] = 0;
1399 #endif
1400         SvREFCNT_dec(PL_psig_name[i]);
1401         to_dec = PL_psig_ptr[i];
1402         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1403         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1404         PL_psig_name[i] = newSVpvn(s, len);
1405         SvREADONLY_on(PL_psig_name[i]);
1406     }
1407     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1408         if (i) {
1409             (void)rsignal(i, PL_csighandlerp);
1410 #ifdef HAS_SIGPROCMASK
1411             LEAVE;
1412 #endif
1413         }
1414         else
1415             *svp = SvREFCNT_inc(sv);
1416         if(to_dec)
1417             SvREFCNT_dec(to_dec);
1418         return 0;
1419     }
1420     s = SvPV_force(sv,len);
1421     if (strEQ(s,"IGNORE")) {
1422         if (i) {
1423 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1424             PL_sig_ignoring[i] = 1;
1425             (void)rsignal(i, PL_csighandlerp);
1426 #else
1427             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1428 #endif
1429         }
1430     }
1431     else if (strEQ(s,"DEFAULT") || !*s) {
1432         if (i)
1433 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1434           {
1435             PL_sig_defaulting[i] = 1;
1436             (void)rsignal(i, PL_csighandlerp);
1437           }
1438 #else
1439             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1440 #endif
1441     }
1442     else {
1443         /*
1444          * We should warn if HINT_STRICT_REFS, but without
1445          * access to a known hint bit in a known OP, we can't
1446          * tell whether HINT_STRICT_REFS is in force or not.
1447          */
1448         if (!strchr(s,':') && !strchr(s,'\''))
1449             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1450         if (i)
1451             (void)rsignal(i, PL_csighandlerp);
1452         else
1453             *svp = SvREFCNT_inc(sv);
1454     }
1455 #ifdef HAS_SIGPROCMASK
1456     if(i)
1457         LEAVE;
1458 #endif
1459     if(to_dec)
1460         SvREFCNT_dec(to_dec);
1461     return 0;
1462 }
1463 #endif /* !PERL_MICRO */
1464
1465 int
1466 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1467 {
1468     dVAR;
1469     PERL_UNUSED_ARG(sv);
1470     PERL_UNUSED_ARG(mg);
1471     PL_sub_generation++;
1472     return 0;
1473 }
1474
1475 int
1476 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1477 {
1478     dVAR;
1479     PERL_UNUSED_ARG(sv);
1480     PERL_UNUSED_ARG(mg);
1481     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1482     PL_amagic_generation++;
1483
1484     return 0;
1485 }
1486
1487 int
1488 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1489 {
1490     HV * const hv = (HV*)LvTARG(sv);
1491     I32 i = 0;
1492     PERL_UNUSED_ARG(mg);
1493
1494     if (hv) {
1495          (void) hv_iterinit(hv);
1496          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1497              i = HvKEYS(hv);
1498          else {
1499              while (hv_iternext(hv))
1500                  i++;
1501          }
1502     }
1503
1504     sv_setiv(sv, (IV)i);
1505     return 0;
1506 }
1507
1508 int
1509 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1510 {
1511     PERL_UNUSED_ARG(mg);
1512     if (LvTARG(sv)) {
1513         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1514     }
1515     return 0;
1516 }
1517
1518 /* caller is responsible for stack switching/cleanup */
1519 STATIC int
1520 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1521 {
1522     dVAR;
1523     dSP;
1524
1525     PUSHMARK(SP);
1526     EXTEND(SP, n);
1527     PUSHs(SvTIED_obj(sv, mg));
1528     if (n > 1) {
1529         if (mg->mg_ptr) {
1530             if (mg->mg_len >= 0)
1531                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1532             else if (mg->mg_len == HEf_SVKEY)
1533                 PUSHs((SV*)mg->mg_ptr);
1534         }
1535         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1536             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1537         }
1538     }
1539     if (n > 2) {
1540         PUSHs(val);
1541     }
1542     PUTBACK;
1543
1544     return call_method(meth, flags);
1545 }
1546
1547 STATIC int
1548 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1549 {
1550     dVAR; dSP;
1551
1552     ENTER;
1553     SAVETMPS;
1554     PUSHSTACKi(PERLSI_MAGIC);
1555
1556     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1557         sv_setsv(sv, *PL_stack_sp--);
1558     }
1559
1560     POPSTACK;
1561     FREETMPS;
1562     LEAVE;
1563     return 0;
1564 }
1565
1566 int
1567 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1568 {
1569     if (mg->mg_ptr)
1570         mg->mg_flags |= MGf_GSKIP;
1571     magic_methpack(sv,mg,"FETCH");
1572     return 0;
1573 }
1574
1575 int
1576 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1577 {
1578     dVAR; dSP;
1579     ENTER;
1580     PUSHSTACKi(PERLSI_MAGIC);
1581     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1582     POPSTACK;
1583     LEAVE;
1584     return 0;
1585 }
1586
1587 int
1588 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1589 {
1590     return magic_methpack(sv,mg,"DELETE");
1591 }
1592
1593
1594 U32
1595 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1596 {
1597     dVAR; dSP;
1598     U32 retval = 0;
1599
1600     ENTER;
1601     SAVETMPS;
1602     PUSHSTACKi(PERLSI_MAGIC);
1603     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1604         sv = *PL_stack_sp--;
1605         retval = (U32) SvIV(sv)-1;
1606     }
1607     POPSTACK;
1608     FREETMPS;
1609     LEAVE;
1610     return retval;
1611 }
1612
1613 int
1614 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1615 {
1616     dVAR; dSP;
1617
1618     ENTER;
1619     PUSHSTACKi(PERLSI_MAGIC);
1620     PUSHMARK(SP);
1621     XPUSHs(SvTIED_obj(sv, mg));
1622     PUTBACK;
1623     call_method("CLEAR", G_SCALAR|G_DISCARD);
1624     POPSTACK;
1625     LEAVE;
1626
1627     return 0;
1628 }
1629
1630 int
1631 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1632 {
1633     dVAR; dSP;
1634     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1635
1636     ENTER;
1637     SAVETMPS;
1638     PUSHSTACKi(PERLSI_MAGIC);
1639     PUSHMARK(SP);
1640     EXTEND(SP, 2);
1641     PUSHs(SvTIED_obj(sv, mg));
1642     if (SvOK(key))
1643         PUSHs(key);
1644     PUTBACK;
1645
1646     if (call_method(meth, G_SCALAR))
1647         sv_setsv(key, *PL_stack_sp--);
1648
1649     POPSTACK;
1650     FREETMPS;
1651     LEAVE;
1652     return 0;
1653 }
1654
1655 int
1656 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1657 {
1658     return magic_methpack(sv,mg,"EXISTS");
1659 }
1660
1661 SV *
1662 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1663 {
1664     dVAR; dSP;
1665     SV *retval = &PL_sv_undef;
1666     SV * const tied = SvTIED_obj((SV*)hv, mg);
1667     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1668
1669     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1670         SV *key;
1671         if (HvEITER_get(hv))
1672             /* we are in an iteration so the hash cannot be empty */
1673             return &PL_sv_yes;
1674         /* no xhv_eiter so now use FIRSTKEY */
1675         key = sv_newmortal();
1676         magic_nextpack((SV*)hv, mg, key);
1677         HvEITER_set(hv, NULL);     /* need to reset iterator */
1678         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1679     }
1680
1681     /* there is a SCALAR method that we can call */
1682     ENTER;
1683     PUSHSTACKi(PERLSI_MAGIC);
1684     PUSHMARK(SP);
1685     EXTEND(SP, 1);
1686     PUSHs(tied);
1687     PUTBACK;
1688
1689     if (call_method("SCALAR", G_SCALAR))
1690         retval = *PL_stack_sp--;
1691     POPSTACK;
1692     LEAVE;
1693     return retval;
1694 }
1695
1696 int
1697 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1698 {
1699     dVAR;
1700     GV * const gv = PL_DBline;
1701     const I32 i = SvTRUE(sv);
1702     SV ** const svp = av_fetch(GvAV(gv),
1703                      atoi(MgPV_nolen_const(mg)), FALSE);
1704     if (svp && SvIOKp(*svp)) {
1705         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1706         if (o) {
1707             /* set or clear breakpoint in the relevant control op */
1708             if (i)
1709                 o->op_flags |= OPf_SPECIAL;
1710             else
1711                 o->op_flags &= ~OPf_SPECIAL;
1712         }
1713     }
1714     return 0;
1715 }
1716
1717 int
1718 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1719 {
1720     dVAR;
1721     const AV * const obj = (AV*)mg->mg_obj;
1722     if (obj) {
1723         sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1724     } else {
1725         SvOK_off(sv);
1726     }
1727     return 0;
1728 }
1729
1730 int
1731 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1732 {
1733     dVAR;
1734     AV * const obj = (AV*)mg->mg_obj;
1735     if (obj) {
1736         av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1737     } else {
1738         if (ckWARN(WARN_MISC))
1739             Perl_warner(aTHX_ packWARN(WARN_MISC),
1740                         "Attempt to set length of freed array");
1741     }
1742     return 0;
1743 }
1744
1745 int
1746 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1747 {
1748     dVAR;
1749     PERL_UNUSED_ARG(sv);
1750     /* during global destruction, mg_obj may already have been freed */
1751     if (PL_in_clean_all)
1752         return 0;
1753
1754     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1755
1756     if (mg) {
1757         /* arylen scalar holds a pointer back to the array, but doesn't own a
1758            reference. Hence the we (the array) are about to go away with it
1759            still pointing at us. Clear its pointer, else it would be pointing
1760            at free memory. See the comment in sv_magic about reference loops,
1761            and why it can't own a reference to us.  */
1762         mg->mg_obj = 0;
1763     }
1764     return 0;
1765 }
1766
1767 int
1768 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1769 {
1770     dVAR;
1771     SV* const lsv = LvTARG(sv);
1772
1773     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1774         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1775         if (mg && mg->mg_len >= 0) {
1776             I32 i = mg->mg_len;
1777             if (DO_UTF8(lsv))
1778                 sv_pos_b2u(lsv, &i);
1779             sv_setiv(sv, i + PL_curcop->cop_arybase);
1780             return 0;
1781         }
1782     }
1783     SvOK_off(sv);
1784     return 0;
1785 }
1786
1787 int
1788 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1789 {
1790     dVAR;
1791     SV* const lsv = LvTARG(sv);
1792     SSize_t pos;
1793     STRLEN len;
1794     STRLEN ulen = 0;
1795
1796     mg = 0;
1797
1798     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1799         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1800     if (!mg) {
1801         if (!SvOK(sv))
1802             return 0;
1803         sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1804         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1805     }
1806     else if (!SvOK(sv)) {
1807         mg->mg_len = -1;
1808         return 0;
1809     }
1810     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1811
1812     pos = SvIV(sv) - PL_curcop->cop_arybase;
1813
1814     if (DO_UTF8(lsv)) {
1815         ulen = sv_len_utf8(lsv);
1816         if (ulen)
1817             len = ulen;
1818     }
1819
1820     if (pos < 0) {
1821         pos += len;
1822         if (pos < 0)
1823             pos = 0;
1824     }
1825     else if (pos > (SSize_t)len)
1826         pos = len;
1827
1828     if (ulen) {
1829         I32 p = pos;
1830         sv_pos_u2b(lsv, &p, 0);
1831         pos = p;
1832     }
1833
1834     mg->mg_len = pos;
1835     mg->mg_flags &= ~MGf_MINMATCH;
1836
1837     return 0;
1838 }
1839
1840 int
1841 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1842 {
1843     PERL_UNUSED_ARG(mg);
1844     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1845         SvFAKE_off(sv);
1846         gv_efullname3(sv,((GV*)sv), "*");
1847         SvFAKE_on(sv);
1848     }
1849     else
1850         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
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 = Nullsv;
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 = Nullsv;
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 = Nullsv;
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) = Nullsv;        /* 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 = Nullsv;
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 = Nullsv;
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) : Nullch;
2210         break;
2211     case '\017':        /* ^O */
2212         if (*(mg->mg_ptr+1) == '\0') {
2213             Safefree(PL_osname);
2214             PL_osname = Nullch;
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 = Nullsv;
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 = Nullsv;
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 = Nullgv;
2624     SV *sv = Nullsv;
2625     SV * const tSv = PL_Sv;
2626     CV *cv = Nullcv;
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_ Nullch);
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  */