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