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