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     STRLEN len = SvCUR(sv); \
 645     char * const p = SvPVX(sv); \
 646     if (p) { \
 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 #ifdef 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 #else
 691 #ifdef VMS
 692              {
 693 #                 include <descrip.h>
 694 #                 include <starlet.h>
 695                   char msg[255];
 696                   $DESCRIPTOR(msgdsc,msg);
 697                   sv_setnv(sv,(NV) vaxc$errno);
 698                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 699                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 700                   else
 701                        sv_setpvn(sv,"",0);
 702              }
 703 #else
 704 #ifdef OS2
 705              if (!(_emx_env & 0x200)) { /* Under DOS */
 706                   sv_setnv(sv, (NV)errno);
 707                   sv_setpv(sv, errno ? Strerror(errno) : "");
 708              } else {
 709                   if (errno != errno_isOS2) {
 710                        const int tmp = _syserrno();
 711                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 712                             Perl_rc = tmp;
 713                   }
 714                   sv_setnv(sv, (NV)Perl_rc);
 715                   sv_setpv(sv, os2error(Perl_rc));
 716              }
 717 #else
 718 #ifdef WIN32
 719              {
 720                   DWORD dwErr = GetLastError();
 721                   sv_setnv(sv, (NV)dwErr);
 722                   if (dwErr) {
 723                        PerlProc_GetOSError(sv, dwErr);
 724                   }
 725                   else
 726                        sv_setpvn(sv, "", 0);
 727                   SetLastError(dwErr);
 728              }
 729 #else
 730              {
 731                  const int saveerrno = errno;
 732                  sv_setnv(sv, (NV)errno);
 733                  sv_setpv(sv, errno ? Strerror(errno) : "");
 734                  errno = saveerrno;
 735              }
 736 #endif
 737 #endif
 738 #endif
 739 #endif
 740              SvRTRIM(sv);
 741              SvNOK_on(sv);      /* what a wonderful hack! */
 742          }
 743          else if (strEQ(remaining, "NCODING"))
 744               sv_setsv(sv, PL_encoding);
 745          break;
 746     case '\006':                /* ^F */
 747         sv_setiv(sv, (IV)PL_maxsysfd);
 748         break;
 749     case '\010':                /* ^H */
 750         sv_setiv(sv, (IV)PL_hints);
 751         break;
 752     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 753         if (PL_inplace)
 754             sv_setpv(sv, PL_inplace);
 755         else
 756             sv_setsv(sv, &PL_sv_undef);
 757         break;
 758     case '\017':                /* ^O & ^OPEN */
 759         if (nextchar == '\0') {
 760             sv_setpv(sv, PL_osname);
 761             SvTAINTED_off(sv);
 762         }
 763         else if (strEQ(remaining, "PEN")) {
 764             if (!PL_compiling.cop_io)
 765                 sv_setsv(sv, &PL_sv_undef);
 766             else {
 767                 sv_setsv(sv, PL_compiling.cop_io);
 768             }
 769         }
 770         break;
 771     case '\020':                /* ^P */
 772         sv_setiv(sv, (IV)PL_perldb);
 773         break;
 774     case '\023':                /* ^S */
 775         if (nextchar == '\0') {
 776             if (PL_lex_state != LEX_NOTPARSING)
 777                 SvOK_off(sv);
 778             else if (PL_in_eval)
 779                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 780             else
 781                 sv_setiv(sv, 0);
 782         }
 783         break;
 784     case '\024':                /* ^T */
 785         if (nextchar == '\0') {
 786 #ifdef BIG_TIME
 787             sv_setnv(sv, PL_basetime);
 788 #else
 789             sv_setiv(sv, (IV)PL_basetime);
 790 #endif
 791         }
 792         else if (strEQ(remaining, "AINT"))
 793             sv_setiv(sv, PL_tainting
 794                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 795                     : 0);
 796         break;
 797     case '\025':                /* $^UNICODE, $^UTF8LOCALE */
 798         if (strEQ(remaining, "NICODE"))
 799             sv_setuv(sv, (UV) PL_unicode);
 800         else if (strEQ(remaining, "TF8LOCALE"))
 801             sv_setuv(sv, (UV) PL_utf8locale);
 802         break;
 803     case '\027':                /* ^W  & $^WARNING_BITS */
 804         if (nextchar == '\0')
 805             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 806         else if (strEQ(remaining, "ARNING_BITS")) {
 807             if (PL_compiling.cop_warnings == pWARN_NONE) {
 808                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 809             }
 810             else if (PL_compiling.cop_warnings == pWARN_STD) {
 811                 sv_setpvn(
 812                     sv,
 813                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 814                     WARNsize
 815                 );
 816             }
 817             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 818                 /* Get the bit mask for $warnings::Bits{all}, because
 819                  * it could have been extended by warnings::register */
 820                 SV **bits_all;
 821                 HV * const bits=get_hv("warnings::Bits", FALSE);
 822                 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
 823                     sv_setsv(sv, *bits_all);
 824                 }
 825                 else {
 826                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 827                 }
 828             }
 829             else {
 830                 sv_setsv(sv, PL_compiling.cop_warnings);
 831             }
 832             SvPOK_only(sv);
 833         }
 834         break;
 835     case '1': case '2': case '3': case '4':
 836     case '5': case '6': case '7': case '8': case '9': case '&':
 837         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 838             I32 s1, t1;
 839
 840             /*
 841              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 842              * XXX Does the new way break anything?
 843              */
 844             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 845           getparen:
 846             if (paren <= (I32)rx->nparens &&
 847                 (s1 = rx->startp[paren]) != -1 &&
 848                 (t1 = rx->endp[paren]) != -1)
 849             {
 850                 i = t1 - s1;
 851                 s = rx->subbeg + s1;
 852                 if (!rx->subbeg)
 853                     break;
 854
 855               getrx:
 856                 if (i >= 0) {
 857                     const int oldtainted = PL_tainted;
 858                     TAINT_NOT;
 859                     sv_setpvn(sv, s, i);
 860                     PL_tainted = oldtainted;
 861                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 862                         SvUTF8_on(sv);
 863                     else
 864                         SvUTF8_off(sv);
 865                     if (PL_tainting) {
 866                         if (RX_MATCH_TAINTED(rx)) {
 867                             MAGIC* const mg = SvMAGIC(sv);
 868                             MAGIC* mgt;
 869                             PL_tainted = 1;
 870                             SvMAGIC_set(sv, mg->mg_moremagic);
 871                             SvTAINT(sv);
 872                             if ((mgt = SvMAGIC(sv))) {
 873                                 mg->mg_moremagic = mgt;
 874                                 SvMAGIC_set(sv, mg);
 875                             }
 876                         } else
 877                             SvTAINTED_off(sv);
 878                     }
 879                     break;
 880                 }
 881             }
 882         }
 883         sv_setsv(sv,&PL_sv_undef);
 884         break;
 885     case '+':
 886         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 887             paren = rx->lastparen;
 888             if (paren)
 889                 goto getparen;
 890         }
 891         sv_setsv(sv,&PL_sv_undef);
 892         break;
 893     case '\016':                /* ^N */
 894         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 895             paren = rx->lastcloseparen;
 896             if (paren)
 897                 goto getparen;
 898         }
 899         sv_setsv(sv,&PL_sv_undef);
 900         break;
 901     case '`':
 902         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 903             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 904                 i = rx->startp[0];
 905                 goto getrx;
 906             }
 907         }
 908         sv_setsv(sv,&PL_sv_undef);
 909         break;
 910     case '\'':
 911         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 912             if (rx->subbeg && rx->endp[0] != -1) {
 913                 s = rx->subbeg + rx->endp[0];
 914                 i = rx->sublen - rx->endp[0];
 915                 goto getrx;
 916             }
 917         }
 918         sv_setsv(sv,&PL_sv_undef);
 919         break;
 920     case '.':
 921         if (GvIO(PL_last_in_gv)) {
 922             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 923         }
 924         break;
 925     case '?':
 926         {
 927             sv_setiv(sv, (IV)STATUS_CURRENT);
 928 #ifdef COMPLEX_STATUS
 929             LvTARGOFF(sv) = PL_statusvalue;
 930             LvTARGLEN(sv) = PL_statusvalue_vms;
 931 #endif
 932         }
 933         break;
 934     case '^':
 935         if (GvIOp(PL_defoutgv))
 936             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 937         if (s)
 938             sv_setpv(sv,s);
 939         else {
 940             sv_setpv(sv,GvENAME(PL_defoutgv));
 941             sv_catpv(sv,"_TOP");
 942         }
 943         break;
 944     case '~':
 945         if (GvIOp(PL_defoutgv))
 946             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 947         if (!s)
 948             s = GvENAME(PL_defoutgv);
 949         sv_setpv(sv,s);
 950         break;
 951     case '=':
 952         if (GvIOp(PL_defoutgv))
 953             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 954         break;
 955     case '-':
 956         if (GvIOp(PL_defoutgv))
 957             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 958         break;
 959     case '%':
 960         if (GvIOp(PL_defoutgv))
 961             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 962         break;
 963     case ':':
 964         break;
 965     case '/':
 966         break;
 967     case '[':
 968         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 969         break;
 970     case '|':
 971         if (GvIOp(PL_defoutgv))
 972             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 973         break;
 974     case ',':
 975         break;
 976     case '\\':
 977         if (PL_ors_sv)
 978             sv_copypv(sv, PL_ors_sv);
 979         break;
 980     case '!':
 981 #ifdef VMS
 982         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 983         sv_setpv(sv, errno ? Strerror(errno) : "");
 984 #else
 985         {
 986         const int saveerrno = errno;
 987         sv_setnv(sv, (NV)errno);
 988 #ifdef OS2
 989         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 990             sv_setpv(sv, os2error(Perl_rc));
 991         else
 992 #endif
 993         sv_setpv(sv, errno ? Strerror(errno) : "");
 994         errno = saveerrno;
 995         }
 996 #endif
 997         SvRTRIM(sv);
 998         SvNOK_on(sv);   /* what a wonderful hack! */
 999         break;
1000     case '<':
1001         sv_setiv(sv, (IV)PL_uid);
1002         break;
1003     case '>':
1004         sv_setiv(sv, (IV)PL_euid);
1005         break;
1006     case '(':
1007         sv_setiv(sv, (IV)PL_gid);
1008         goto add_groups;
1009     case ')':
1010         sv_setiv(sv, (IV)PL_egid);
1011       add_groups:
1012 #ifdef HAS_GETGROUPS
1013         {
1014             Groups_t *gary = NULL;
1015             I32 i, num_groups = getgroups(0, gary);
1016             Newx(gary, num_groups, Groups_t);
1017             num_groups = getgroups(num_groups, gary);
1018             for (i = 0; i < num_groups; i++)
1019                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1020             Safefree(gary);
1021         }
1022         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1023 #endif
1024         break;
1025 #ifndef MACOS_TRADITIONAL
1026     case '0':
1027         break;
1028 #endif
1029     }
1030     return 0;
1031 }
1032
1033 int
1034 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1035 {
1036     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1037
1038     if (uf && uf->uf_val)
1039         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1040     return 0;
1041 }
1042
1043 int
1044 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1045 {
1046     dVAR;
1047     STRLEN len, klen;
1048     const char *s = SvPV_const(sv,len);
1049     const char * const ptr = MgPV_const(mg,klen);
1050     my_setenv(ptr, s);
1051
1052 #ifdef DYNAMIC_ENV_FETCH
1053      /* We just undefd an environment var.  Is a replacement */
1054      /* waiting in the wings? */
1055     if (!len) {
1056         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1057         if (valp)
1058             s = SvPV_const(*valp, len);
1059     }
1060 #endif
1061
1062 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1063                             /* And you'll never guess what the dog had */
1064                             /*   in its mouth... */
1065     if (PL_tainting) {
1066         MgTAINTEDDIR_off(mg);
1067 #ifdef VMS
1068         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1069             char pathbuf[256], eltbuf[256], *cp, *elt;
1070             Stat_t sbuf;
1071             int i = 0, j = 0;
1072
1073             strncpy(eltbuf, s, 255);
1074             eltbuf[255] = 0;
1075             elt = eltbuf;
1076             do {          /* DCL$PATH may be a search list */
1077                 while (1) {   /* as may dev portion of any element */
1078                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1079                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1080                              cando_by_name(S_IWUSR,0,elt) ) {
1081                             MgTAINTEDDIR_on(mg);
1082                             return 0;
1083                         }
1084                     }
1085                     if ((cp = strchr(elt, ':')) != Nullch)
1086                         *cp = '\0';
1087                     if (my_trnlnm(elt, eltbuf, j++))
1088                         elt = eltbuf;
1089                     else
1090                         break;
1091                 }
1092                 j = 0;
1093             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1094         }
1095 #endif /* VMS */
1096         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1097             const char * const strend = s + len;
1098
1099             while (s < strend) {
1100                 char tmpbuf[256];
1101                 Stat_t st;
1102                 I32 i;
1103                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1104                              s, strend, ':', &i);
1105                 s++;
1106                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1107                       || *tmpbuf != '/'
1108                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1109                     MgTAINTEDDIR_on(mg);
1110                     return 0;
1111                 }
1112             }
1113         }
1114     }
1115 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1116
1117     return 0;
1118 }
1119
1120 int
1121 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1122 {
1123     PERL_UNUSED_ARG(sv);
1124     my_setenv(MgPV_nolen_const(mg),Nullch);
1125     return 0;
1126 }
1127
1128 int
1129 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1130 {
1131     dVAR;
1132     PERL_UNUSED_ARG(mg);
1133 #if defined(VMS)
1134     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1135 #else
1136     if (PL_localizing) {
1137         HE* entry;
1138         my_clearenv();
1139         hv_iterinit((HV*)sv);
1140         while ((entry = hv_iternext((HV*)sv))) {
1141             I32 keylen;
1142             my_setenv(hv_iterkey(entry, &keylen),
1143                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1144         }
1145     }
1146 #endif
1147     return 0;
1148 }
1149
1150 int
1151 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1152 {
1153     dVAR;
1154     PERL_UNUSED_ARG(sv);
1155     PERL_UNUSED_ARG(mg);
1156 #if defined(VMS)
1157     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1158 #else
1159     my_clearenv();
1160 #endif
1161     return 0;
1162 }
1163
1164 #ifndef PERL_MICRO
1165 #ifdef HAS_SIGPROCMASK
1166 static void
1167 restore_sigmask(pTHX_ SV *save_sv)
1168 {
1169     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1170     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1171 }
1172 #endif
1173 int
1174 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1175 {
1176     dVAR;
1177     /* Are we fetching a signal entry? */
1178     const I32 i = whichsig(MgPV_nolen_const(mg));
1179     if (i > 0) {
1180         if(PL_psig_ptr[i])
1181             sv_setsv(sv,PL_psig_ptr[i]);
1182         else {
1183             Sighandler_t sigstate;
1184             sigstate = rsignal_state(i);
1185 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1186             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1187 #endif
1188 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1189             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1190 #endif
1191             /* cache state so we don't fetch it again */
1192             if(sigstate == (Sighandler_t) SIG_IGN)
1193                 sv_setpv(sv,"IGNORE");
1194             else
1195                 sv_setsv(sv,&PL_sv_undef);
1196             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1197             SvTEMP_off(sv);
1198         }
1199     }
1200     return 0;
1201 }
1202 int
1203 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1204 {
1205     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1206      * refactoring might be in order.
1207      */
1208     dVAR;
1209     register const char * const s = MgPV_nolen_const(mg);
1210     PERL_UNUSED_ARG(sv);
1211     if (*s == '_') {
1212         SV** svp = NULL;
1213         if (strEQ(s,"__DIE__"))
1214             svp = &PL_diehook;
1215         else if (strEQ(s,"__WARN__"))
1216             svp = &PL_warnhook;
1217         else
1218             Perl_croak(aTHX_ "No such hook: %s", s);
1219         if (svp && *svp) {
1220             SV * const to_dec = *svp;
1221             *svp = NULL;
1222             SvREFCNT_dec(to_dec);
1223         }
1224     }
1225     else {
1226         /* Are we clearing a signal entry? */
1227         const I32 i = whichsig(s);
1228         if (i > 0) {
1229 #ifdef HAS_SIGPROCMASK
1230             sigset_t set, save;
1231             SV* save_sv;
1232             /* Avoid having the signal arrive at a bad time, if possible. */
1233             sigemptyset(&set);
1234             sigaddset(&set,i);
1235             sigprocmask(SIG_BLOCK, &set, &save);
1236             ENTER;
1237             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1238             SAVEFREESV(save_sv);
1239             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1240 #endif
1241             PERL_ASYNC_CHECK();
1242 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1243             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1244 #endif
1245 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1246             PL_sig_defaulting[i] = 1;
1247             (void)rsignal(i, PL_csighandlerp);
1248 #else
1249             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1250 #endif
1251             if(PL_psig_name[i]) {
1252                 SvREFCNT_dec(PL_psig_name[i]);
1253                 PL_psig_name[i]=0;
1254             }
1255             if(PL_psig_ptr[i]) {
1256                 SV * const to_dec=PL_psig_ptr[i];
1257                 PL_psig_ptr[i]=0;
1258                 LEAVE;
1259                 SvREFCNT_dec(to_dec);
1260             }
1261             else
1262                 LEAVE;
1263         }
1264     }
1265     return 0;
1266 }
1267
1268 static void
1269 S_raise_signal(pTHX_ int sig)
1270 {
1271     dVAR;
1272     /* Set a flag to say this signal is pending */
1273     PL_psig_pend[sig]++;
1274     /* And one to say _a_ signal is pending */
1275     PL_sig_pending = 1;
1276 }
1277
1278 Signal_t
1279 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1280 Perl_csighandler(int sig, ...)
1281 #else
1282 Perl_csighandler(int sig)
1283 #endif
1284 {
1285 #ifdef PERL_GET_SIG_CONTEXT
1286     dTHXa(PERL_GET_SIG_CONTEXT);
1287 #else
1288     dTHX;
1289 #endif
1290 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1291     (void) rsignal(sig, PL_csighandlerp);
1292     if (PL_sig_ignoring[sig]) return;
1293 #endif
1294 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1295     if (PL_sig_defaulting[sig])
1296 #ifdef KILL_BY_SIGPRC
1297             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1298 #else
1299             exit(1);
1300 #endif
1301 #endif
1302    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1303         /* Call the perl level handler now--
1304          * with risk we may be in malloc() etc. */
1305         (*PL_sighandlerp)(sig);
1306    else
1307         S_raise_signal(aTHX_ sig);
1308 }
1309
1310 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1311 void
1312 Perl_csighandler_init(void)
1313 {
1314     int sig;
1315     if (PL_sig_handlers_initted) return;
1316
1317     for (sig = 1; sig < SIG_SIZE; sig++) {
1318 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1319         dTHX;
1320         PL_sig_defaulting[sig] = 1;
1321         (void) rsignal(sig, PL_csighandlerp);
1322 #endif
1323 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1324         PL_sig_ignoring[sig] = 0;
1325 #endif
1326     }
1327     PL_sig_handlers_initted = 1;
1328 }
1329 #endif
1330
1331 void
1332 Perl_despatch_signals(pTHX)
1333 {
1334     dVAR;
1335     int sig;
1336     PL_sig_pending = 0;
1337     for (sig = 1; sig < SIG_SIZE; sig++) {
1338         if (PL_psig_pend[sig]) {
1339             PERL_BLOCKSIG_ADD(set, sig);
1340             PL_psig_pend[sig] = 0;
1341             PERL_BLOCKSIG_BLOCK(set);
1342             (*PL_sighandlerp)(sig);
1343             PERL_BLOCKSIG_UNBLOCK(set);
1344         }
1345     }
1346 }
1347
1348 int
1349 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1350 {
1351     dVAR;
1352     I32 i;
1353     SV** svp = NULL;
1354     /* Need to be careful with SvREFCNT_dec(), because that can have side
1355      * effects (due to closures). We must make sure that the new disposition
1356      * is in place before it is called.
1357      */
1358     SV* to_dec = NULL;
1359     STRLEN len;
1360 #ifdef HAS_SIGPROCMASK
1361     sigset_t set, save;
1362     SV* save_sv;
1363 #endif
1364
1365     register const char *s = MgPV_const(mg,len);
1366     if (*s == '_') {
1367         if (strEQ(s,"__DIE__"))
1368             svp = &PL_diehook;
1369         else if (strEQ(s,"__WARN__"))
1370             svp = &PL_warnhook;
1371         else
1372             Perl_croak(aTHX_ "No such hook: %s", s);
1373         i = 0;
1374         if (*svp) {
1375             to_dec = *svp;
1376             *svp = NULL;
1377         }
1378     }
1379     else {
1380         i = whichsig(s);        /* ...no, a brick */
1381         if (i <= 0) {
1382             if (ckWARN(WARN_SIGNAL))
1383                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1384             return 0;
1385         }
1386 #ifdef HAS_SIGPROCMASK
1387         /* Avoid having the signal arrive at a bad time, if possible. */
1388         sigemptyset(&set);
1389         sigaddset(&set,i);
1390         sigprocmask(SIG_BLOCK, &set, &save);
1391         ENTER;
1392         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1393         SAVEFREESV(save_sv);
1394         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1395 #endif
1396         PERL_ASYNC_CHECK();
1397 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1398         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1399 #endif
1400 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1401         PL_sig_ignoring[i] = 0;
1402 #endif
1403 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1404         PL_sig_defaulting[i] = 0;
1405 #endif
1406         SvREFCNT_dec(PL_psig_name[i]);
1407         to_dec = PL_psig_ptr[i];
1408         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1409         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1410         PL_psig_name[i] = newSVpvn(s, len);
1411         SvREADONLY_on(PL_psig_name[i]);
1412     }
1413     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1414         if (i) {
1415             (void)rsignal(i, PL_csighandlerp);
1416 #ifdef HAS_SIGPROCMASK
1417             LEAVE;
1418 #endif
1419         }
1420         else
1421             *svp = SvREFCNT_inc(sv);
1422         if(to_dec)
1423             SvREFCNT_dec(to_dec);
1424         return 0;
1425     }
1426     s = SvPV_force(sv,len);
1427     if (strEQ(s,"IGNORE")) {
1428         if (i) {
1429 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1430             PL_sig_ignoring[i] = 1;
1431             (void)rsignal(i, PL_csighandlerp);
1432 #else
1433             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1434 #endif
1435         }
1436     }
1437     else if (strEQ(s,"DEFAULT") || !*s) {
1438         if (i)
1439 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1440           {
1441             PL_sig_defaulting[i] = 1;
1442             (void)rsignal(i, PL_csighandlerp);
1443           }
1444 #else
1445             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1446 #endif
1447     }
1448     else {
1449         /*
1450          * We should warn if HINT_STRICT_REFS, but without
1451          * access to a known hint bit in a known OP, we can't
1452          * tell whether HINT_STRICT_REFS is in force or not.
1453          */
1454         if (!strchr(s,':') && !strchr(s,'\''))
1455             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1456         if (i)
1457             (void)rsignal(i, PL_csighandlerp);
1458         else
1459             *svp = SvREFCNT_inc(sv);
1460     }
1461 #ifdef HAS_SIGPROCMASK
1462     if(i)
1463         LEAVE;
1464 #endif
1465     if(to_dec)
1466         SvREFCNT_dec(to_dec);
1467     return 0;
1468 }
1469 #endif /* !PERL_MICRO */
1470
1471 int
1472 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1473 {
1474     dVAR;
1475     PERL_UNUSED_ARG(sv);
1476     PERL_UNUSED_ARG(mg);
1477     PL_sub_generation++;
1478     return 0;
1479 }
1480
1481 int
1482 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1483 {
1484     dVAR;
1485     PERL_UNUSED_ARG(sv);
1486     PERL_UNUSED_ARG(mg);
1487     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1488     PL_amagic_generation++;
1489
1490     return 0;
1491 }
1492
1493 int
1494 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1495 {
1496     HV * const hv = (HV*)LvTARG(sv);
1497     I32 i = 0;
1498     PERL_UNUSED_ARG(mg);
1499
1500     if (hv) {
1501          (void) hv_iterinit(hv);
1502          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1503              i = HvKEYS(hv);
1504          else {
1505              while (hv_iternext(hv))
1506                  i++;
1507          }
1508     }
1509
1510     sv_setiv(sv, (IV)i);
1511     return 0;
1512 }
1513
1514 int
1515 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1516 {
1517     PERL_UNUSED_ARG(mg);
1518     if (LvTARG(sv)) {
1519         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1520     }
1521     return 0;
1522 }
1523
1524 /* caller is responsible for stack switching/cleanup */
1525 STATIC int
1526 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1527 {
1528     dVAR;
1529     dSP;
1530
1531     PUSHMARK(SP);
1532     EXTEND(SP, n);
1533     PUSHs(SvTIED_obj(sv, mg));
1534     if (n > 1) {
1535         if (mg->mg_ptr) {
1536             if (mg->mg_len >= 0)
1537                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1538             else if (mg->mg_len == HEf_SVKEY)
1539                 PUSHs((SV*)mg->mg_ptr);
1540         }
1541         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1542             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1543         }
1544     }
1545     if (n > 2) {
1546         PUSHs(val);
1547     }
1548     PUTBACK;
1549
1550     return call_method(meth, flags);
1551 }
1552
1553 STATIC int
1554 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1555 {
1556     dVAR; dSP;
1557
1558     ENTER;
1559     SAVETMPS;
1560     PUSHSTACKi(PERLSI_MAGIC);
1561
1562     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1563         sv_setsv(sv, *PL_stack_sp--);
1564     }
1565
1566     POPSTACK;
1567     FREETMPS;
1568     LEAVE;
1569     return 0;
1570 }
1571
1572 int
1573 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1574 {
1575     if (mg->mg_ptr)
1576         mg->mg_flags |= MGf_GSKIP;
1577     magic_methpack(sv,mg,"FETCH");
1578     return 0;
1579 }
1580
1581 int
1582 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1583 {
1584     dVAR; dSP;
1585     ENTER;
1586     PUSHSTACKi(PERLSI_MAGIC);
1587     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1588     POPSTACK;
1589     LEAVE;
1590     return 0;
1591 }
1592
1593 int
1594 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1595 {
1596     return magic_methpack(sv,mg,"DELETE");
1597 }
1598
1599
1600 U32
1601 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1602 {
1603     dVAR; dSP;
1604     U32 retval = 0;
1605
1606     ENTER;
1607     SAVETMPS;
1608     PUSHSTACKi(PERLSI_MAGIC);
1609     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1610         sv = *PL_stack_sp--;
1611         retval = (U32) SvIV(sv)-1;
1612     }
1613     POPSTACK;
1614     FREETMPS;
1615     LEAVE;
1616     return retval;
1617 }
1618
1619 int
1620 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1621 {
1622     dVAR; dSP;
1623
1624     ENTER;
1625     PUSHSTACKi(PERLSI_MAGIC);
1626     PUSHMARK(SP);
1627     XPUSHs(SvTIED_obj(sv, mg));
1628     PUTBACK;
1629     call_method("CLEAR", G_SCALAR|G_DISCARD);
1630     POPSTACK;
1631     LEAVE;
1632
1633     return 0;
1634 }
1635
1636 int
1637 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1638 {
1639     dVAR; dSP;
1640     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1641
1642     ENTER;
1643     SAVETMPS;
1644     PUSHSTACKi(PERLSI_MAGIC);
1645     PUSHMARK(SP);
1646     EXTEND(SP, 2);
1647     PUSHs(SvTIED_obj(sv, mg));
1648     if (SvOK(key))
1649         PUSHs(key);
1650     PUTBACK;
1651
1652     if (call_method(meth, G_SCALAR))
1653         sv_setsv(key, *PL_stack_sp--);
1654
1655     POPSTACK;
1656     FREETMPS;
1657     LEAVE;
1658     return 0;
1659 }
1660
1661 int
1662 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1663 {
1664     return magic_methpack(sv,mg,"EXISTS");
1665 }
1666
1667 SV *
1668 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1669 {
1670     dVAR; dSP;
1671     SV *retval = &PL_sv_undef;
1672     SV * const tied = SvTIED_obj((SV*)hv, mg);
1673     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1674
1675     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1676         SV *key;
1677         if (HvEITER_get(hv))
1678             /* we are in an iteration so the hash cannot be empty */
1679             return &PL_sv_yes;
1680         /* no xhv_eiter so now use FIRSTKEY */
1681         key = sv_newmortal();
1682         magic_nextpack((SV*)hv, mg, key);
1683         HvEITER_set(hv, NULL);     /* need to reset iterator */
1684         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1685     }
1686
1687     /* there is a SCALAR method that we can call */
1688     ENTER;
1689     PUSHSTACKi(PERLSI_MAGIC);
1690     PUSHMARK(SP);
1691     EXTEND(SP, 1);
1692     PUSHs(tied);
1693     PUTBACK;
1694
1695     if (call_method("SCALAR", G_SCALAR))
1696         retval = *PL_stack_sp--;
1697     POPSTACK;
1698     LEAVE;
1699     return retval;
1700 }
1701
1702 int
1703 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1704 {
1705     dVAR;
1706     GV * const gv = PL_DBline;
1707     const I32 i = SvTRUE(sv);
1708     SV ** const svp = av_fetch(GvAV(gv),
1709                      atoi(MgPV_nolen_const(mg)), FALSE);
1710     if (svp && SvIOKp(*svp)) {
1711         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1712         if (o) {
1713             /* set or clear breakpoint in the relevant control op */
1714             if (i)
1715                 o->op_flags |= OPf_SPECIAL;
1716             else
1717                 o->op_flags &= ~OPf_SPECIAL;
1718         }
1719     }
1720     return 0;
1721 }
1722
1723 int
1724 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1725 {
1726     dVAR;
1727     const AV * const obj = (AV*)mg->mg_obj;
1728     if (obj) {
1729         sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1730     } else {
1731         SvOK_off(sv);
1732     }
1733     return 0;
1734 }
1735
1736 int
1737 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1738 {
1739     dVAR;
1740     AV * const obj = (AV*)mg->mg_obj;
1741     if (obj) {
1742         av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1743     } else {
1744         if (ckWARN(WARN_MISC))
1745             Perl_warner(aTHX_ packWARN(WARN_MISC),
1746                         "Attempt to set length of freed array");
1747     }
1748     return 0;
1749 }
1750
1751 int
1752 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1753 {
1754     dVAR;
1755     PERL_UNUSED_ARG(sv);
1756     /* during global destruction, mg_obj may already have been freed */
1757     if (PL_in_clean_all)
1758         return 0;
1759
1760     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1761
1762     if (mg) {
1763         /* arylen scalar holds a pointer back to the array, but doesn't own a
1764            reference. Hence the we (the array) are about to go away with it
1765            still pointing at us. Clear its pointer, else it would be pointing
1766            at free memory. See the comment in sv_magic about reference loops,
1767            and why it can't own a reference to us.  */
1768         mg->mg_obj = 0;
1769     }
1770     return 0;
1771 }
1772
1773 int
1774 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1775 {
1776     dVAR;
1777     SV* const lsv = LvTARG(sv);
1778
1779     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1780         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1781         if (mg && mg->mg_len >= 0) {
1782             I32 i = mg->mg_len;
1783             if (DO_UTF8(lsv))
1784                 sv_pos_b2u(lsv, &i);
1785             sv_setiv(sv, i + PL_curcop->cop_arybase);
1786             return 0;
1787         }
1788     }
1789     SvOK_off(sv);
1790     return 0;
1791 }
1792
1793 int
1794 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1795 {
1796     dVAR;
1797     SV* const lsv = LvTARG(sv);
1798     SSize_t pos;
1799     STRLEN len;
1800     STRLEN ulen = 0;
1801
1802     mg = 0;
1803
1804     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1805         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1806     if (!mg) {
1807         if (!SvOK(sv))
1808             return 0;
1809         sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1810         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1811     }
1812     else if (!SvOK(sv)) {
1813         mg->mg_len = -1;
1814         return 0;
1815     }
1816     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1817
1818     pos = SvIV(sv) - PL_curcop->cop_arybase;
1819
1820     if (DO_UTF8(lsv)) {
1821         ulen = sv_len_utf8(lsv);
1822         if (ulen)
1823             len = ulen;
1824     }
1825
1826     if (pos < 0) {
1827         pos += len;
1828         if (pos < 0)
1829             pos = 0;
1830     }
1831     else if (pos > (SSize_t)len)
1832         pos = len;
1833
1834     if (ulen) {
1835         I32 p = pos;
1836         sv_pos_u2b(lsv, &p, 0);
1837         pos = p;
1838     }
1839
1840     mg->mg_len = pos;
1841     mg->mg_flags &= ~MGf_MINMATCH;
1842
1843     return 0;
1844 }
1845
1846 int
1847 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1848 {
1849     PERL_UNUSED_ARG(mg);
1850     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1851         SvFAKE_off(sv);
1852         gv_efullname3(sv,((GV*)sv), "*");
1853         SvFAKE_on(sv);
1854     }
1855     else
1856         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1857     return 0;
1858 }
1859
1860 int
1861 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1862 {
1863     GV* gv;
1864     PERL_UNUSED_ARG(mg);
1865
1866     if (!SvOK(sv))
1867         return 0;
1868     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1869     if (sv == (SV*)gv)
1870         return 0;
1871     if (GvGP(sv))
1872         gp_free((GV*)sv);
1873     GvGP(sv) = gp_ref(GvGP(gv));
1874     return 0;
1875 }
1876
1877 int
1878 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1879 {
1880     STRLEN len;
1881     SV * const lsv = LvTARG(sv);
1882     const char * const tmps = SvPV_const(lsv,len);
1883     I32 offs = LvTARGOFF(sv);
1884     I32 rem = LvTARGLEN(sv);
1885     PERL_UNUSED_ARG(mg);
1886
1887     if (SvUTF8(lsv))
1888         sv_pos_u2b(lsv, &offs, &rem);
1889     if (offs > (I32)len)
1890         offs = len;
1891     if (rem + offs > (I32)len)
1892         rem = len - offs;
1893     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1894     if (SvUTF8(lsv))
1895         SvUTF8_on(sv);
1896     return 0;
1897 }
1898
1899 int
1900 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1901 {
1902     dVAR;
1903     STRLEN len;
1904     const char *tmps = SvPV_const(sv, len);
1905     SV * const lsv = LvTARG(sv);
1906     I32 lvoff = LvTARGOFF(sv);
1907     I32 lvlen = LvTARGLEN(sv);
1908     PERL_UNUSED_ARG(mg);
1909
1910     if (DO_UTF8(sv)) {
1911         sv_utf8_upgrade(lsv);
1912         sv_pos_u2b(lsv, &lvoff, &lvlen);
1913         sv_insert(lsv, lvoff, lvlen, tmps, len);
1914         LvTARGLEN(sv) = sv_len_utf8(sv);
1915         SvUTF8_on(lsv);
1916     }
1917     else if (lsv && SvUTF8(lsv)) {
1918         sv_pos_u2b(lsv, &lvoff, &lvlen);
1919         LvTARGLEN(sv) = len;
1920         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1921         sv_insert(lsv, lvoff, lvlen, tmps, len);
1922         Safefree(tmps);
1923     }
1924     else {
1925         sv_insert(lsv, lvoff, lvlen, tmps, len);
1926         LvTARGLEN(sv) = len;
1927     }
1928
1929
1930     return 0;
1931 }
1932
1933 int
1934 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1935 {
1936     dVAR;
1937     PERL_UNUSED_ARG(sv);
1938     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1939     return 0;
1940 }
1941
1942 int
1943 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1944 {
1945     dVAR;
1946     PERL_UNUSED_ARG(sv);
1947     /* update taint status unless we're restoring at scope exit */
1948     if (PL_localizing != 2) {
1949         if (PL_tainted)
1950             mg->mg_len |= 1;
1951         else
1952             mg->mg_len &= ~1;
1953     }
1954     return 0;
1955 }
1956
1957 int
1958 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1959 {
1960     SV * const lsv = LvTARG(sv);
1961     PERL_UNUSED_ARG(mg);
1962
1963     if (lsv)
1964         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1965     else
1966         SvOK_off(sv);
1967
1968     return 0;
1969 }
1970
1971 int
1972 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1973 {
1974     PERL_UNUSED_ARG(mg);
1975     do_vecset(sv);      /* XXX slurp this routine */
1976     return 0;
1977 }
1978
1979 int
1980 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1981 {
1982     dVAR;
1983     SV *targ = Nullsv;
1984     if (LvTARGLEN(sv)) {
1985         if (mg->mg_obj) {
1986             SV * const ahv = LvTARG(sv);
1987             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1988             if (he)
1989                 targ = HeVAL(he);
1990         }
1991         else {
1992             AV* const av = (AV*)LvTARG(sv);
1993             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1994                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1995         }
1996         if (targ && targ != &PL_sv_undef) {
1997             /* somebody else defined it for us */
1998             SvREFCNT_dec(LvTARG(sv));
1999             LvTARG(sv) = SvREFCNT_inc(targ);
2000             LvTARGLEN(sv) = 0;
2001             SvREFCNT_dec(mg->mg_obj);
2002             mg->mg_obj = Nullsv;
2003             mg->mg_flags &= ~MGf_REFCOUNTED;
2004         }
2005     }
2006     else
2007         targ = LvTARG(sv);
2008     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2009     return 0;
2010 }
2011
2012 int
2013 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2014 {
2015     PERL_UNUSED_ARG(mg);
2016     if (LvTARGLEN(sv))
2017         vivify_defelem(sv);
2018     if (LvTARG(sv)) {
2019         sv_setsv(LvTARG(sv), sv);
2020         SvSETMAGIC(LvTARG(sv));
2021     }
2022     return 0;
2023 }
2024
2025 void
2026 Perl_vivify_defelem(pTHX_ SV *sv)
2027 {
2028     dVAR;
2029     MAGIC *mg;
2030     SV *value = Nullsv;
2031
2032     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2033         return;
2034     if (mg->mg_obj) {
2035         SV * const ahv = LvTARG(sv);
2036         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2037         if (he)
2038             value = HeVAL(he);
2039         if (!value || value == &PL_sv_undef)
2040             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2041     }
2042     else {
2043         AV* const av = (AV*)LvTARG(sv);
2044         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2045             LvTARG(sv) = Nullsv;        /* array can't be extended */
2046         else {
2047             SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2048             if (!svp || (value = *svp) == &PL_sv_undef)
2049                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2050         }
2051     }
2052     (void)SvREFCNT_inc(value);
2053     SvREFCNT_dec(LvTARG(sv));
2054     LvTARG(sv) = value;
2055     LvTARGLEN(sv) = 0;
2056     SvREFCNT_dec(mg->mg_obj);
2057     mg->mg_obj = Nullsv;
2058     mg->mg_flags &= ~MGf_REFCOUNTED;
2059 }
2060
2061 int
2062 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2063 {
2064     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2065 }
2066
2067 int
2068 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2069 {
2070     mg->mg_len = -1;
2071     SvSCREAM_off(sv);
2072     return 0;
2073 }
2074
2075 int
2076 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2077 {
2078     PERL_UNUSED_ARG(mg);
2079     sv_unmagic(sv, PERL_MAGIC_bm);
2080     SvVALID_off(sv);
2081     return 0;
2082 }
2083
2084 int
2085 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2086 {
2087     PERL_UNUSED_ARG(mg);
2088     sv_unmagic(sv, PERL_MAGIC_fm);
2089     SvCOMPILED_off(sv);
2090     return 0;
2091 }
2092
2093 int
2094 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2095 {
2096     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2097
2098     if (uf && uf->uf_set)
2099         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2100     return 0;
2101 }
2102
2103 int
2104 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2105 {
2106     PERL_UNUSED_ARG(mg);
2107     sv_unmagic(sv, PERL_MAGIC_qr);
2108     return 0;
2109 }
2110
2111 int
2112 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2113 {
2114     dVAR;
2115     regexp * const re = (regexp *)mg->mg_obj;
2116     PERL_UNUSED_ARG(sv);
2117
2118     ReREFCNT_dec(re);
2119     return 0;
2120 }
2121
2122 #ifdef USE_LOCALE_COLLATE
2123 int
2124 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2125 {
2126     /*
2127      * RenE<eacute> Descartes said "I think not."
2128      * and vanished with a faint plop.
2129      */
2130     PERL_UNUSED_ARG(sv);
2131     if (mg->mg_ptr) {
2132         Safefree(mg->mg_ptr);
2133         mg->mg_ptr = NULL;
2134         mg->mg_len = -1;
2135     }
2136     return 0;
2137 }
2138 #endif /* USE_LOCALE_COLLATE */
2139
2140 /* Just clear the UTF-8 cache data. */
2141 int
2142 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2143 {
2144     PERL_UNUSED_ARG(sv);
2145     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2146     mg->mg_ptr = 0;
2147     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2148     return 0;
2149 }
2150
2151 int
2152 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2153 {
2154     dVAR;
2155     register const char *s;
2156     I32 i;
2157     STRLEN len;
2158     switch (*mg->mg_ptr) {
2159     case '\001':        /* ^A */
2160         sv_setsv(PL_bodytarget, sv);
2161         break;
2162     case '\003':        /* ^C */
2163         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2164         break;
2165
2166     case '\004':        /* ^D */
2167 #ifdef DEBUGGING
2168         s = SvPV_nolen_const(sv);
2169         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2170         DEBUG_x(dump_all());
2171 #else
2172         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2173 #endif
2174         break;
2175     case '\005':  /* ^E */
2176         if (*(mg->mg_ptr+1) == '\0') {
2177 #ifdef MACOS_TRADITIONAL
2178             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2179 #else
2180 #  ifdef VMS
2181             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2182 #  else
2183 #    ifdef WIN32
2184             SetLastError( SvIV(sv) );
2185 #    else
2186 #      ifdef OS2
2187             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2188 #      else
2189             /* will anyone ever use this? */
2190             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2191 #      endif
2192 #    endif
2193 #  endif
2194 #endif
2195         }
2196         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2197             if (PL_encoding)
2198                 SvREFCNT_dec(PL_encoding);
2199             if (SvOK(sv) || SvGMAGICAL(sv)) {
2200                 PL_encoding = newSVsv(sv);
2201             }
2202             else {
2203                 PL_encoding = Nullsv;
2204             }
2205         }
2206         break;
2207     case '\006':        /* ^F */
2208         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2209         break;
2210     case '\010':        /* ^H */
2211         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2212         break;
2213     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2214         Safefree(PL_inplace);
2215         PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2216         break;
2217     case '\017':        /* ^O */
2218         if (*(mg->mg_ptr+1) == '\0') {
2219             Safefree(PL_osname);
2220             PL_osname = Nullch;
2221             if (SvOK(sv)) {
2222                 TAINT_PROPER("assigning to $^O");
2223                 PL_osname = savesvpv(sv);
2224             }
2225         }
2226         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2227             if (!PL_compiling.cop_io)
2228                 PL_compiling.cop_io = newSVsv(sv);
2229             else
2230                 sv_setsv(PL_compiling.cop_io,sv);
2231         }
2232         break;
2233     case '\020':        /* ^P */
2234         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2235         if (PL_perldb && !PL_DBsingle)
2236             init_debugger();
2237         break;
2238     case '\024':        /* ^T */
2239 #ifdef BIG_TIME
2240         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2241 #else
2242         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2243 #endif
2244         break;
2245     case '\027':        /* ^W & $^WARNING_BITS */
2246         if (*(mg->mg_ptr+1) == '\0') {
2247             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2248                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2249                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2250                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2251             }
2252         }
2253         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2254             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2255                 if (!SvPOK(sv) && PL_localizing) {
2256                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2257                     PL_compiling.cop_warnings = pWARN_NONE;
2258                     break;
2259                 }
2260                 {
2261                     STRLEN len, i;
2262                     int accumulate = 0 ;
2263                     int any_fatals = 0 ;
2264                     const char * const ptr = SvPV_const(sv, len) ;
2265                     for (i = 0 ; i < len ; ++i) {
2266                         accumulate |= ptr[i] ;
2267                         any_fatals |= (ptr[i] & 0xAA) ;
2268                     }
2269                     if (!accumulate)
2270                         PL_compiling.cop_warnings = pWARN_NONE;
2271                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2272                         PL_compiling.cop_warnings = pWARN_ALL;
2273                         PL_dowarn |= G_WARN_ONCE ;
2274                     }
2275                     else {
2276                         if (specialWARN(PL_compiling.cop_warnings))
2277                             PL_compiling.cop_warnings = newSVsv(sv) ;
2278                         else
2279                             sv_setsv(PL_compiling.cop_warnings, sv);
2280                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2281                             PL_dowarn |= G_WARN_ONCE ;
2282                     }
2283
2284                 }
2285             }
2286         }
2287         break;
2288     case '.':
2289         if (PL_localizing) {
2290             if (PL_localizing == 1)
2291                 SAVESPTR(PL_last_in_gv);
2292         }
2293         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2294             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2295         break;
2296     case '^':
2297         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2298         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2299         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2300         break;
2301     case '~':
2302         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2303         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2304         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2305         break;
2306     case '=':
2307         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2308         break;
2309     case '-':
2310         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2311         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2312             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2313         break;
2314     case '%':
2315         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2316         break;
2317     case '|':
2318         {
2319             IO * const io = GvIOp(PL_defoutgv);
2320             if(!io)
2321               break;
2322             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2323                 IoFLAGS(io) &= ~IOf_FLUSH;
2324             else {
2325                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2326                     PerlIO *ofp = IoOFP(io);
2327                     if (ofp)
2328                         (void)PerlIO_flush(ofp);
2329                     IoFLAGS(io) |= IOf_FLUSH;
2330                 }
2331             }
2332         }
2333         break;
2334     case '/':
2335         SvREFCNT_dec(PL_rs);
2336         PL_rs = newSVsv(sv);
2337         break;
2338     case '\\':
2339         if (PL_ors_sv)
2340             SvREFCNT_dec(PL_ors_sv);
2341         if (SvOK(sv) || SvGMAGICAL(sv)) {
2342             PL_ors_sv = newSVsv(sv);
2343         }
2344         else {
2345             PL_ors_sv = Nullsv;
2346         }
2347         break;
2348     case ',':
2349         if (PL_ofs_sv)
2350             SvREFCNT_dec(PL_ofs_sv);
2351         if (SvOK(sv) || SvGMAGICAL(sv)) {
2352             PL_ofs_sv = newSVsv(sv);
2353         }
2354         else {
2355             PL_ofs_sv = Nullsv;
2356         }
2357         break;
2358     case '[':
2359         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2360         break;
2361     case '?':
2362 #ifdef COMPLEX_STATUS
2363         if (PL_localizing == 2) {
2364             PL_statusvalue = LvTARGOFF(sv);
2365             PL_statusvalue_vms = LvTARGLEN(sv);
2366         }
2367         else
2368 #endif
2369 #ifdef VMSISH_STATUS
2370         if (VMSISH_STATUS)
2371             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2372         else
2373 #endif
2374             STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2375         break;
2376     case '!':
2377         {
2378 #ifdef VMS
2379 #   define PERL_VMS_BANG vaxc$errno
2380 #else
2381 #   define PERL_VMS_BANG 0
2382 #endif
2383         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2384                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2385         }
2386         break;
2387     case '<':
2388         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2389         if (PL_delaymagic) {
2390             PL_delaymagic |= DM_RUID;
2391             break;                              /* don't do magic till later */
2392         }
2393 #ifdef HAS_SETRUID
2394         (void)setruid((Uid_t)PL_uid);
2395 #else
2396 #ifdef HAS_SETREUID
2397         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2398 #else
2399 #ifdef HAS_SETRESUID
2400       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2401 #else
2402         if (PL_uid == PL_euid) {                /* special case $< = $> */
2403 #ifdef PERL_DARWIN
2404             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2405             if (PL_uid != 0 && PerlProc_getuid() == 0)
2406                 (void)PerlProc_setuid(0);
2407 #endif
2408             (void)PerlProc_setuid(PL_uid);
2409         } else {
2410             PL_uid = PerlProc_getuid();
2411             Perl_croak(aTHX_ "setruid() not implemented");
2412         }
2413 #endif
2414 #endif
2415 #endif
2416         PL_uid = PerlProc_getuid();
2417         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2418         break;
2419     case '>':
2420         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2421         if (PL_delaymagic) {
2422             PL_delaymagic |= DM_EUID;
2423             break;                              /* don't do magic till later */
2424         }
2425 #ifdef HAS_SETEUID
2426         (void)seteuid((Uid_t)PL_euid);
2427 #else
2428 #ifdef HAS_SETREUID
2429         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2430 #else
2431 #ifdef HAS_SETRESUID
2432         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2433 #else
2434         if (PL_euid == PL_uid)          /* special case $> = $< */
2435             PerlProc_setuid(PL_euid);
2436         else {
2437             PL_euid = PerlProc_geteuid();
2438             Perl_croak(aTHX_ "seteuid() not implemented");
2439         }
2440 #endif
2441 #endif
2442 #endif
2443         PL_euid = PerlProc_geteuid();
2444         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2445         break;
2446     case '(':
2447         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2448         if (PL_delaymagic) {
2449             PL_delaymagic |= DM_RGID;
2450             break;                              /* don't do magic till later */
2451         }
2452 #ifdef HAS_SETRGID
2453         (void)setrgid((Gid_t)PL_gid);
2454 #else
2455 #ifdef HAS_SETREGID
2456         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2457 #else
2458 #ifdef HAS_SETRESGID
2459       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2460 #else
2461         if (PL_gid == PL_egid)                  /* special case $( = $) */
2462             (void)PerlProc_setgid(PL_gid);
2463         else {
2464             PL_gid = PerlProc_getgid();
2465             Perl_croak(aTHX_ "setrgid() not implemented");
2466         }
2467 #endif
2468 #endif
2469 #endif
2470         PL_gid = PerlProc_getgid();
2471         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2472         break;
2473     case ')':
2474 #ifdef HAS_SETGROUPS
2475         {
2476             const char *p = SvPV_const(sv, len);
2477             Groups_t *gary = NULL;
2478
2479             while (isSPACE(*p))
2480                 ++p;
2481             PL_egid = Atol(p);
2482             for (i = 0; i < NGROUPS; ++i) {
2483                 while (*p && !isSPACE(*p))
2484                     ++p;
2485                 while (isSPACE(*p))
2486                     ++p;
2487                 if (!*p)
2488                     break;
2489                 if(!gary)
2490                     Newx(gary, i + 1, Groups_t);
2491                 else
2492                     Renew(gary, i + 1, Groups_t);
2493                 gary[i] = Atol(p);
2494             }
2495             if (i)
2496                 (void)setgroups(i, gary);
2497             if (gary)
2498                 Safefree(gary);
2499         }
2500 #else  /* HAS_SETGROUPS */
2501         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2502 #endif /* HAS_SETGROUPS */
2503         if (PL_delaymagic) {
2504             PL_delaymagic |= DM_EGID;
2505             break;                              /* don't do magic till later */
2506         }
2507 #ifdef HAS_SETEGID
2508         (void)setegid((Gid_t)PL_egid);
2509 #else
2510 #ifdef HAS_SETREGID
2511         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2512 #else
2513 #ifdef HAS_SETRESGID
2514         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2515 #else
2516         if (PL_egid == PL_gid)                  /* special case $) = $( */
2517             (void)PerlProc_setgid(PL_egid);
2518         else {
2519             PL_egid = PerlProc_getegid();
2520             Perl_croak(aTHX_ "setegid() not implemented");
2521         }
2522 #endif
2523 #endif
2524 #endif
2525         PL_egid = PerlProc_getegid();
2526         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2527         break;
2528     case ':':
2529         PL_chopset = SvPV_force(sv,len);
2530         break;
2531 #ifndef MACOS_TRADITIONAL
2532     case '0':
2533         LOCK_DOLLARZERO_MUTEX;
2534 #ifdef HAS_SETPROCTITLE
2535         /* The BSDs don't show the argv[] in ps(1) output, they
2536          * show a string from the process struct and provide
2537          * the setproctitle() routine to manipulate that. */
2538         if (PL_origalen != 1) {
2539             s = SvPV_const(sv, len);
2540 #   if __FreeBSD_version > 410001
2541             /* The leading "-" removes the "perl: " prefix,
2542              * but not the "(perl) suffix from the ps(1)
2543              * output, because that's what ps(1) shows if the
2544              * argv[] is modified. */
2545             setproctitle("-%s", s);
2546 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2547             /* This doesn't really work if you assume that
2548              * $0 = 'foobar'; will wipe out 'perl' from the $0
2549              * because in ps(1) output the result will be like
2550              * sprintf("perl: %s (perl)", s)
2551              * I guess this is a security feature:
2552              * one (a user process) cannot get rid of the original name.
2553              * --jhi */
2554             setproctitle("%s", s);
2555 #   endif
2556         }
2557 #endif
2558 #if defined(__hpux) && defined(PSTAT_SETCMD)
2559         if (PL_origalen != 1) {
2560              union pstun un;
2561              s = SvPV_const(sv, len);
2562              un.pst_command = (char *)s;
2563              pstat(PSTAT_SETCMD, un, len, 0, 0);
2564         }
2565 #endif
2566         if (PL_origalen > 1) {
2567             /* PL_origalen is set in perl_parse(). */
2568             s = SvPV_force(sv,len);
2569             if (len >= (STRLEN)PL_origalen-1) {
2570                 /* Longer than original, will be truncated. We assume that
2571                  * PL_origalen bytes are available. */
2572                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2573             }
2574             else {
2575                 /* Shorter than original, will be padded. */
2576                 Copy(s, PL_origargv[0], len, char);
2577                 PL_origargv[0][len] = 0;
2578                 memset(PL_origargv[0] + len + 1,
2579                        /* Is the space counterintuitive?  Yes.
2580                         * (You were expecting \0?)
2581                         * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2582                         * --jhi */
2583                        (int)' ',
2584                        PL_origalen - len - 1);
2585             }
2586             PL_origargv[0][PL_origalen-1] = 0;
2587             for (i = 1; i < PL_origargc; i++)
2588                 PL_origargv[i] = 0;
2589         }
2590         UNLOCK_DOLLARZERO_MUTEX;
2591         break;
2592 #endif
2593     }
2594     return 0;
2595 }
2596
2597 I32
2598 Perl_whichsig(pTHX_ const char *sig)
2599 {
2600     register char* const* sigv;
2601
2602     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2603         if (strEQ(sig,*sigv))
2604             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2605 #ifdef SIGCLD
2606     if (strEQ(sig,"CHLD"))
2607         return SIGCLD;
2608 #endif
2609 #ifdef SIGCHLD
2610     if (strEQ(sig,"CLD"))
2611         return SIGCHLD;
2612 #endif
2613     return -1;
2614 }
2615
2616 Signal_t
2617 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2618 Perl_sighandler(int sig, ...)
2619 #else
2620 Perl_sighandler(int sig)
2621 #endif
2622 {
2623 #ifdef PERL_GET_SIG_CONTEXT
2624     dTHXa(PERL_GET_SIG_CONTEXT);
2625 #else
2626     dTHX;
2627 #endif
2628     dSP;
2629     GV *gv = Nullgv;
2630     SV *sv = Nullsv;
2631     SV * const tSv = PL_Sv;
2632     CV *cv = Nullcv;
2633     OP *myop = PL_op;
2634     U32 flags = 0;
2635     XPV * const tXpv = PL_Xpv;
2636
2637     if (PL_savestack_ix + 15 <= PL_savestack_max)
2638         flags |= 1;
2639     if (PL_markstack_ptr < PL_markstack_max - 2)
2640         flags |= 4;
2641     if (PL_scopestack_ix < PL_scopestack_max - 3)
2642         flags |= 16;
2643
2644     if (!PL_psig_ptr[sig]) {
2645                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2646                                  PL_sig_name[sig]);
2647                 exit(sig);
2648         }
2649
2650     /* Max number of items pushed there is 3*n or 4. We cannot fix
2651        infinity, so we fix 4 (in fact 5): */
2652     if (flags & 1) {
2653         PL_savestack_ix += 5;           /* Protect save in progress. */
2654         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2655     }
2656     if (flags & 4)
2657         PL_markstack_ptr++;             /* Protect mark. */
2658     if (flags & 16)
2659         PL_scopestack_ix += 1;
2660     /* sv_2cv is too complicated, try a simpler variant first: */
2661     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2662         || SvTYPE(cv) != SVt_PVCV) {
2663         HV *st;
2664         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2665     }
2666
2667     if (!cv || !CvROOT(cv)) {
2668         if (ckWARN(WARN_SIGNAL))
2669             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2670                 PL_sig_name[sig], (gv ? GvENAME(gv)
2671                                 : ((cv && CvGV(cv))
2672                                    ? GvENAME(CvGV(cv))
2673                                    : "__ANON__")));
2674         goto cleanup;
2675     }
2676
2677     if(PL_psig_name[sig]) {
2678         sv = SvREFCNT_inc(PL_psig_name[sig]);
2679         flags |= 64;
2680 #if !defined(PERL_IMPLICIT_CONTEXT)
2681         PL_sig_sv = sv;
2682 #endif
2683     } else {
2684         sv = sv_newmortal();
2685         sv_setpv(sv,PL_sig_name[sig]);
2686     }
2687
2688     PUSHSTACKi(PERLSI_SIGNAL);
2689     PUSHMARK(SP);
2690     PUSHs(sv);
2691 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2692     {
2693          struct sigaction oact;
2694
2695          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2696               siginfo_t *sip;
2697               va_list args;
2698
2699               va_start(args, sig);
2700               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2701               if (sip) {
2702                    HV *sih = newHV();
2703                    SV *rv  = newRV_noinc((SV*)sih);
2704                    /* The siginfo fields signo, code, errno, pid, uid,
2705                     * addr, status, and band are defined by POSIX/SUSv3. */
2706                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2707                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2708 #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. */
2709                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2710                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2711                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2712                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2713                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2714                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2715 #endif
2716                    EXTEND(SP, 2);
2717                    PUSHs((SV*)rv);
2718                    PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2719               }
2720
2721               va_end(args);
2722          }
2723     }
2724 #endif
2725     PUTBACK;
2726
2727     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2728
2729     POPSTACK;
2730     if (SvTRUE(ERRSV)) {
2731 #ifndef PERL_MICRO
2732 #ifdef HAS_SIGPROCMASK
2733         /* Handler "died", for example to get out of a restart-able read().
2734          * Before we re-do that on its behalf re-enable the signal which was
2735          * blocked by the system when we entered.
2736          */
2737         sigset_t set;
2738         sigemptyset(&set);
2739         sigaddset(&set,sig);
2740         sigprocmask(SIG_UNBLOCK, &set, NULL);
2741 #else
2742         /* Not clear if this will work */
2743         (void)rsignal(sig, SIG_IGN);
2744         (void)rsignal(sig, PL_csighandlerp);
2745 #endif
2746 #endif /* !PERL_MICRO */
2747         Perl_die(aTHX_ Nullch);
2748     }
2749 cleanup:
2750     if (flags & 1)
2751         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2752     if (flags & 4)
2753         PL_markstack_ptr--;
2754     if (flags & 16)
2755         PL_scopestack_ix -= 1;
2756     if (flags & 64)
2757         SvREFCNT_dec(sv);
2758     PL_op = myop;                       /* Apparently not needed... */
2759
2760     PL_Sv = tSv;                        /* Restore global temporaries. */
2761     PL_Xpv = tXpv;
2762     return;
2763 }
2764
2765
2766 static void
2767 S_restore_magic(pTHX_ const void *p)
2768 {
2769     dVAR;
2770     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2771     SV* const sv = mgs->mgs_sv;
2772
2773     if (!sv)
2774         return;
2775
2776     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2777     {
2778 #ifdef PERL_OLD_COPY_ON_WRITE
2779         /* While magic was saved (and off) sv_setsv may well have seen
2780            this SV as a prime candidate for COW.  */
2781         if (SvIsCOW(sv))
2782             sv_force_normal_flags(sv, 0);
2783 #endif
2784
2785         if (mgs->mgs_flags)
2786             SvFLAGS(sv) |= mgs->mgs_flags;
2787         else
2788             mg_magical(sv);
2789         if (SvGMAGICAL(sv)) {
2790             /* downgrade public flags to private,
2791                and discard any other private flags */
2792
2793             U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2794             if (public) {
2795                 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2796                 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2797             }
2798         }
2799     }
2800
2801     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2802
2803     /* If we're still on top of the stack, pop us off.  (That condition
2804      * will be satisfied if restore_magic was called explicitly, but *not*
2805      * if it's being called via leave_scope.)
2806      * The reason for doing this is that otherwise, things like sv_2cv()
2807      * may leave alloc gunk on the savestack, and some code
2808      * (e.g. sighandler) doesn't expect that...
2809      */
2810     if (PL_savestack_ix == mgs->mgs_ss_ix)
2811     {
2812         I32 popval = SSPOPINT;
2813         assert(popval == SAVEt_DESTRUCTOR_X);
2814         PL_savestack_ix -= 2;
2815         popval = SSPOPINT;
2816         assert(popval == SAVEt_ALLOC);
2817         popval = SSPOPINT;
2818         PL_savestack_ix -= popval;
2819     }
2820
2821 }
2822
2823 static void
2824 S_unwind_handler_stack(pTHX_ const void *p)
2825 {
2826     dVAR;
2827     const U32 flags = *(const U32*)p;
2828
2829     if (flags & 1)
2830         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2831 #if !defined(PERL_IMPLICIT_CONTEXT)
2832     if (flags & 64)
2833         SvREFCNT_dec(PL_sig_sv);
2834 #endif
2835 }
2836
2837 /*
2838  * Local variables:
2839  * c-indentation-style: bsd
2840  * c-basic-offset: 4
2841  * indent-tabs-mode: t
2842  * End:
2843  *
2844  * ex: set ts=8 sts=4 sw=4 noet:
2845  */