mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "Sam sat on the ground and put his head in his hands.  'I wish I had never
  13  * come here, and I don't want to see no more magic,' he said, and fell silent."
  14  */
  15
  16 /*
  17 =head1 Magical Functions
  18
  19 "Magic" is special data attached to SV structures in order to give them
  20 "magical" properties.  When any Perl code tries to read from, or assign to,
  21 an SV marked as magical, it calls the 'get' or 'set' function associated
  22 with that SV's magic. A get is called prior to reading an SV, in order to
  23 give it a chance to update its internal value (get on $. writes the line
  24 number of the last read filehandle into to the SV's IV slot), while
  25 set is called after an SV has been written to, in order to allow it to make
  26 use of its changed value (set on $/ copies the SV's new value to the
  27 PL_rs global variable).
  28
  29 Magic is implemented as a linked list of MAGIC structures attached to the
  30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
  31 of functions that implement the get(), set(), length() etc functions,
  32 plus space for some flags and pointers. For example, a tied variable has
  33 a MAGIC structure that contains a pointer to the object associated with the
  34 tie.
  35
  36 */
  37
  38 #include "EXTERN.h"
  39 #define PERL_IN_MG_C
  40 #include "perl.h"
  41
  42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
  43 #  ifdef I_GRP
  44 #    include <grp.h>
  45 #  endif
  46 #endif
  47
  48 #if defined(HAS_SETGROUPS)
  49 #  ifndef NGROUPS
  50 #    define NGROUPS 32
  51 #  endif
  52 #endif
  53
  54 #ifdef __hpux
  55 #  include <sys/pstat.h>
  56 #endif
  57
  58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
  59 Signal_t Perl_csighandler(int sig, ...);
  60 #else
  61 Signal_t Perl_csighandler(int sig);
  62 #endif
  63
  64 #ifdef __Lynx__
  65 /* Missing protos on LynxOS */
  66 void setruid(uid_t id);
  67 void seteuid(uid_t id);
  68 void setrgid(uid_t id);
  69 void setegid(uid_t id);
  70 #endif
  71
  72 /*
  73  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  74  */
  75
  76 struct magic_state {
  77     SV* mgs_sv;
  78     U32 mgs_flags;
  79     I32 mgs_ss_ix;
  80 };
  81 /* MGS is typedef'ed to struct magic_state in perl.h */
  82
  83 STATIC void
  84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
  85 {
  86     dVAR;
  87     MGS* mgs;
  88     assert(SvMAGICAL(sv));
  89     /* Turning READONLY off for a copy-on-write scalar (including shared
  90        hash keys) is a bad idea.  */
  91     if (SvIsCOW(sv))
  92       sv_force_normal_flags(sv, 0);
  93
  94     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
  95
  96     mgs = SSPTR(mgs_ix, MGS*);
  97     mgs->mgs_sv = sv;
  98     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  99     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
 100
 101     SvMAGICAL_off(sv);
 102     SvREADONLY_off(sv);
 103     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 104 }
 105
 106 /*
 107 =for apidoc mg_magical
 108
 109 Turns on the magical status of an SV.  See C<sv_magic>.
 110
 111 =cut
 112 */
 113
 114 void
 115 Perl_mg_magical(pTHX_ SV *sv)
 116 {
 117     const MAGIC* mg;
 118     PERL_UNUSED_CONTEXT;
 119     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 120         const MGVTBL* const vtbl = mg->mg_virtual;
 121         if (vtbl) {
 122             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 123                 SvGMAGICAL_on(sv);
 124             if (vtbl->svt_set)
 125                 SvSMAGICAL_on(sv);
 126             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
 127                 SvRMAGICAL_on(sv);
 128         }
 129     }
 130 }
 131
 132 /*
 133 =for apidoc mg_get
 134
 135 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 136
 137 =cut
 138 */
 139
 140 int
 141 Perl_mg_get(pTHX_ SV *sv)
 142 {
 143     dVAR;
 144     const I32 mgs_ix = SSNEW(sizeof(MGS));
 145     const bool was_temp = (bool)SvTEMP(sv);
 146     int have_new = 0;
 147     MAGIC *newmg, *head, *cur, *mg;
 148     /* guard against sv having being freed midway by holding a private
 149        reference. */
 150
 151     /* sv_2mortal has this side effect of turning on the TEMP flag, which can
 152        cause the SV's buffer to get stolen (and maybe other stuff).
 153        So restore it.
 154     */
 155     sv_2mortal(SvREFCNT_inc_simple(sv));
 156     if (!was_temp) {
 157         SvTEMP_off(sv);
 158     }
 159
 160     save_magic(mgs_ix, sv);
 161
 162     /* We must call svt_get(sv, mg) for each valid entry in the linked
 163        list of magic. svt_get() may delete the current entry, add new
 164        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 165
 166     newmg = cur = head = mg = SvMAGIC(sv);
 167     while (mg) {
 168         const MGVTBL * const vtbl = mg->mg_virtual;
 169
 170         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 171             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 172
 173             /* guard against magic having been deleted - eg FETCH calling
 174              * untie */
 175             if (!SvMAGIC(sv))
 176                 break;
 177
 178             /* Don't restore the flags for this entry if it was deleted. */
 179             if (mg->mg_flags & MGf_GSKIP)
 180                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
 181         }
 182
 183         mg = mg->mg_moremagic;
 184
 185         if (have_new) {
 186             /* Have we finished with the new entries we saw? Start again
 187                where we left off (unless there are more new entries). */
 188             if (mg == head) {
 189                 have_new = 0;
 190                 mg   = cur;
 191                 head = newmg;
 192             }
 193         }
 194
 195         /* Were any new entries added? */
 196         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
 197             have_new = 1;
 198             cur = mg;
 199             mg  = newmg;
 200         }
 201     }
 202
 203     restore_magic(INT2PTR(void *, (IV)mgs_ix));
 204
 205     if (SvREFCNT(sv) == 1) {
 206         /* We hold the last reference to this SV, which implies that the
 207            SV was deleted as a side effect of the routines we called.  */
 208         SvOK_off(sv);
 209     }
 210     return 0;
 211 }
 212
 213 /*
 214 =for apidoc mg_set
 215
 216 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 217
 218 =cut
 219 */
 220
 221 int
 222 Perl_mg_set(pTHX_ SV *sv)
 223 {
 224     dVAR;
 225     const I32 mgs_ix = SSNEW(sizeof(MGS));
 226     MAGIC* mg;
 227     MAGIC* nextmg;
 228
 229     save_magic(mgs_ix, sv);
 230
 231     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 232         const MGVTBL* vtbl = mg->mg_virtual;
 233         nextmg = mg->mg_moremagic;      /* it may delete itself */
 234         if (mg->mg_flags & MGf_GSKIP) {
 235             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 236             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
 237         }
 238         if (vtbl && vtbl->svt_set)
 239             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
 240     }
 241
 242     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 243     return 0;
 244 }
 245
 246 /*
 247 =for apidoc mg_length
 248
 249 Report on the SV's length.  See C<sv_magic>.
 250
 251 =cut
 252 */
 253
 254 U32
 255 Perl_mg_length(pTHX_ SV *sv)
 256 {
 257     dVAR;
 258     MAGIC* mg;
 259     STRLEN len;
 260
 261     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 262         const MGVTBL * const vtbl = mg->mg_virtual;
 263         if (vtbl && vtbl->svt_len) {
 264             const I32 mgs_ix = SSNEW(sizeof(MGS));
 265             save_magic(mgs_ix, sv);
 266             /* omit MGf_GSKIP -- not changed here */
 267             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 268             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 269             return len;
 270         }
 271     }
 272
 273     if (DO_UTF8(sv)) {
 274         const U8 *s = (U8*)SvPV_const(sv, len);
 275         len = Perl_utf8_length(aTHX_ s, s + len);
 276     }
 277     else
 278         (void)SvPV_const(sv, len);
 279     return len;
 280 }
 281
 282 I32
 283 Perl_mg_size(pTHX_ SV *sv)
 284 {
 285     MAGIC* mg;
 286
 287     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 288         const MGVTBL* const vtbl = mg->mg_virtual;
 289         if (vtbl && vtbl->svt_len) {
 290             const I32 mgs_ix = SSNEW(sizeof(MGS));
 291             I32 len;
 292             save_magic(mgs_ix, sv);
 293             /* omit MGf_GSKIP -- not changed here */
 294             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 295             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 296             return len;
 297         }
 298     }
 299
 300     switch(SvTYPE(sv)) {
 301         case SVt_PVAV:
 302             return AvFILLp((AV *) sv); /* Fallback to non-tied array */
 303         case SVt_PVHV:
 304             /* FIXME */
 305         default:
 306             Perl_croak(aTHX_ "Size magic not implemented");
 307             break;
 308     }
 309     return 0;
 310 }
 311
 312 /*
 313 =for apidoc mg_clear
 314
 315 Clear something magical that the SV represents.  See C<sv_magic>.
 316
 317 =cut
 318 */
 319
 320 int
 321 Perl_mg_clear(pTHX_ SV *sv)
 322 {
 323     const I32 mgs_ix = SSNEW(sizeof(MGS));
 324     MAGIC* mg;
 325
 326     save_magic(mgs_ix, sv);
 327
 328     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 329         const MGVTBL* const vtbl = mg->mg_virtual;
 330         /* omit GSKIP -- never set here */
 331
 332         if (vtbl && vtbl->svt_clear)
 333             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 334     }
 335
 336     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 337     return 0;
 338 }
 339
 340 /*
 341 =for apidoc mg_find
 342
 343 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 344
 345 =cut
 346 */
 347
 348 MAGIC*
 349 Perl_mg_find(pTHX_ const SV *sv, int type)
 350 {
 351     PERL_UNUSED_CONTEXT;
 352     if (sv) {
 353         MAGIC *mg;
 354         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 355             if (mg->mg_type == type)
 356                 return mg;
 357         }
 358     }
 359     return NULL;
 360 }
 361
 362 /*
 363 =for apidoc mg_copy
 364
 365 Copies the magic from one SV to another.  See C<sv_magic>.
 366
 367 =cut
 368 */
 369
 370 int
 371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 372 {
 373     int count = 0;
 374     MAGIC* mg;
 375     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 376         const MGVTBL* const vtbl = mg->mg_virtual;
 377         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 378             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 379         }
 380         else {
 381             const char type = mg->mg_type;
 382             if (isUPPER(type)) {
 383                 sv_magic(nsv,
 384                      (type == PERL_MAGIC_tied)
 385                         ? SvTIED_obj(sv, mg)
 386                         : (type == PERL_MAGIC_regdata && mg->mg_obj)
 387                             ? sv
 388                             : mg->mg_obj,
 389                      toLOWER(type), key, klen);
 390                 count++;
 391             }
 392         }
 393     }
 394     return count;
 395 }
 396
 397 /*
 398 =for apidoc mg_localize
 399
 400 Copy some of the magic from an existing SV to new localized version of
 401 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
 402 doesn't (eg taint, pos).
 403
 404 =cut
 405 */
 406
 407 void
 408 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
 409 {
 410     dVAR;
 411     MAGIC *mg;
 412     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 413         MGVTBL* const vtbl = mg->mg_virtual;
 414         switch (mg->mg_type) {
 415         /* value magic types: don't copy */
 416         case PERL_MAGIC_bm:
 417         case PERL_MAGIC_fm:
 418         case PERL_MAGIC_regex_global:
 419         case PERL_MAGIC_nkeys:
 420 #ifdef USE_LOCALE_COLLATE
 421         case PERL_MAGIC_collxfrm:
 422 #endif
 423         case PERL_MAGIC_qr:
 424         case PERL_MAGIC_taint:
 425         case PERL_MAGIC_vec:
 426         case PERL_MAGIC_vstring:
 427         case PERL_MAGIC_utf8:
 428         case PERL_MAGIC_substr:
 429         case PERL_MAGIC_defelem:
 430         case PERL_MAGIC_arylen:
 431         case PERL_MAGIC_pos:
 432         case PERL_MAGIC_backref:
 433         case PERL_MAGIC_arylen_p:
 434         case PERL_MAGIC_rhash:
 435         case PERL_MAGIC_symtab:
 436             continue;
 437         }
 438
 439         if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
 440             (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
 441         else
 442             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 443                             mg->mg_ptr, mg->mg_len);
 444
 445         /* container types should remain read-only across localization */
 446         SvFLAGS(nsv) |= SvREADONLY(sv);
 447     }
 448
 449     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 450         SvFLAGS(nsv) |= SvMAGICAL(sv);
 451         PL_localizing = 1;
 452         SvSETMAGIC(nsv);
 453         PL_localizing = 0;
 454     }
 455 }
 456
 457 /*
 458 =for apidoc mg_free
 459
 460 Free any magic storage used by the SV.  See C<sv_magic>.
 461
 462 =cut
 463 */
 464
 465 int
 466 Perl_mg_free(pTHX_ SV *sv)
 467 {
 468     MAGIC* mg;
 469     MAGIC* moremagic;
 470     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 471         const MGVTBL* const vtbl = mg->mg_virtual;
 472         moremagic = mg->mg_moremagic;
 473         if (vtbl && vtbl->svt_free)
 474             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 475         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 476             if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 477                 Safefree(mg->mg_ptr);
 478             else if (mg->mg_len == HEf_SVKEY)
 479                 SvREFCNT_dec((SV*)mg->mg_ptr);
 480         }
 481         if (mg->mg_flags & MGf_REFCOUNTED)
 482             SvREFCNT_dec(mg->mg_obj);
 483         Safefree(mg);
 484     }
 485     SvMAGIC_set(sv, NULL);
 486     return 0;
 487 }
 488
 489 #include <signal.h>
 490
 491 U32
 492 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 493 {
 494     dVAR;
 495     PERL_UNUSED_ARG(sv);
 496
 497     if (PL_curpm) {
 498         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 499         if (rx) {
 500             return mg->mg_obj
 501                 ? rx->nparens       /* @+ */
 502                 : rx->lastparen;    /* @- */
 503         }
 504     }
 505
 506     return (U32)-1;
 507 }
 508
 509 int
 510 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 511 {
 512     dVAR;
 513     if (PL_curpm) {
 514         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 515         if (rx) {
 516             register const I32 paren = mg->mg_len;
 517             register I32 s;
 518             register I32 t;
 519             if (paren < 0)
 520                 return 0;
 521             if (paren <= (I32)rx->nparens &&
 522                 (s = rx->startp[paren]) != -1 &&
 523                 (t = rx->endp[paren]) != -1)
 524                 {
 525                     register I32 i;
 526                     if (mg->mg_obj)             /* @+ */
 527                         i = t;
 528                     else                        /* @- */
 529                         i = s;
 530
 531                     if (i > 0 && RX_MATCH_UTF8(rx)) {
 532                         const char * const b = rx->subbeg;
 533                         if (b)
 534                             i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
 535                     }
 536
 537                     sv_setiv(sv, i);
 538                 }
 539         }
 540     }
 541     return 0;
 542 }
 543
 544 int
 545 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 546 {
 547     PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
 548     Perl_croak(aTHX_ PL_no_modify);
 549     NORETURN_FUNCTION_END;
 550 }
 551
 552 U32
 553 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 554 {
 555     dVAR;
 556     register I32 paren;
 557     register I32 i;
 558     register const REGEXP *rx;
 559     I32 s1, t1;
 560
 561     switch (*mg->mg_ptr) {
 562     case '1': case '2': case '3': case '4':
 563     case '5': case '6': case '7': case '8': case '9': case '&':
 564         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 565
 566             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 567           getparen:
 568             if (paren <= (I32)rx->nparens &&
 569                 (s1 = rx->startp[paren]) != -1 &&
 570                 (t1 = rx->endp[paren]) != -1)
 571             {
 572                 i = t1 - s1;
 573               getlen:
 574                 if (i > 0 && RX_MATCH_UTF8(rx)) {
 575                     const char * const s = rx->subbeg + s1;
 576                     const U8 *ep;
 577                     STRLEN el;
 578
 579                     i = t1 - s1;
 580                     if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
 581                         i = el;
 582                 }
 583                 if (i < 0)
 584                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 585                 return i;
 586             }
 587             else {
 588                 if (ckWARN(WARN_UNINITIALIZED))
 589                     report_uninit(sv);
 590             }
 591         }
 592         else {
 593             if (ckWARN(WARN_UNINITIALIZED))
 594                 report_uninit(sv);
 595         }
 596         return 0;
 597     case '+':
 598         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 599             paren = rx->lastparen;
 600             if (paren)
 601                 goto getparen;
 602         }
 603         return 0;
 604     case '\016': /* ^N */
 605         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 606             paren = rx->lastcloseparen;
 607             if (paren)
 608                 goto getparen;
 609         }
 610         return 0;
 611     case '`':
 612         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 613             if (rx->startp[0] != -1) {
 614                 i = rx->startp[0];
 615                 if (i > 0) {
 616                     s1 = 0;
 617                     t1 = i;
 618                     goto getlen;
 619                 }
 620             }
 621         }
 622         return 0;
 623     case '\'':
 624         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 625             if (rx->endp[0] != -1) {
 626                 i = rx->sublen - rx->endp[0];
 627                 if (i > 0) {
 628                     s1 = rx->endp[0];
 629                     t1 = rx->sublen;
 630                     goto getlen;
 631                 }
 632             }
 633         }
 634         return 0;
 635     }
 636     magic_get(sv,mg);
 637     if (!SvPOK(sv) && SvNIOK(sv)) {
 638         sv_2pv(sv, 0);
 639     }
 640     if (SvPOK(sv))
 641         return SvCUR(sv);
 642     return 0;
 643 }
 644
 645 #define SvRTRIM(sv) STMT_START { \
 646     if (SvPOK(sv)) { \
 647         STRLEN len = SvCUR(sv); \
 648         char * const p = SvPVX(sv); \
 649         while (len > 0 && isSPACE(p[len-1])) \
 650            --len; \
 651         SvCUR_set(sv, len); \
 652         p[len] = '\0'; \
 653     } \
 654 } STMT_END
 655
 656 int
 657 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 658 {
 659     dVAR;
 660     register I32 paren;
 661     register char *s = NULL;
 662     register I32 i;
 663     register REGEXP *rx;
 664     const char * const remaining = mg->mg_ptr + 1;
 665     const char nextchar = *remaining;
 666
 667     switch (*mg->mg_ptr) {
 668     case '\001':                /* ^A */
 669         sv_setsv(sv, PL_bodytarget);
 670         break;
 671     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 672         if (nextchar == '\0') {
 673             sv_setiv(sv, (IV)PL_minus_c);
 674         }
 675         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 676             sv_setiv(sv, (IV)STATUS_NATIVE);
 677         }
 678         break;
 679
 680     case '\004':                /* ^D */
 681         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 682         break;
 683     case '\005':  /* ^E */
 684          if (nextchar == '\0') {
 685 #if defined(MACOS_TRADITIONAL)
 686              {
 687                   char msg[256];
 688
 689                   sv_setnv(sv,(double)gMacPerl_OSErr);
 690                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 691              }
 692 #elif defined(VMS)
 693              {
 694 #                 include <descrip.h>
 695 #                 include <starlet.h>
 696                   char msg[255];
 697                   $DESCRIPTOR(msgdsc,msg);
 698                   sv_setnv(sv,(NV) vaxc$errno);
 699                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 700                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 701                   else
 702                        sv_setpvn(sv,"",0);
 703              }
 704 #elif defined(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 #elif defined(WIN32)
 718              {
 719                   DWORD dwErr = GetLastError();
 720                   sv_setnv(sv, (NV)dwErr);
 721                   if (dwErr) {
 722                        PerlProc_GetOSError(sv, dwErr);
 723                   }
 724                   else
 725                        sv_setpvn(sv, "", 0);
 726                   SetLastError(dwErr);
 727              }
 728 #else
 729              {
 730                  const int saveerrno = errno;
 731                  sv_setnv(sv, (NV)errno);
 732                  sv_setpv(sv, errno ? Strerror(errno) : "");
 733                  errno = saveerrno;
 734              }
 735 #endif
 736              SvRTRIM(sv);
 737              SvNOK_on(sv);      /* what a wonderful hack! */
 738          }
 739          else if (strEQ(remaining, "NCODING"))
 740               sv_setsv(sv, PL_encoding);
 741          break;
 742     case '\006':                /* ^F */
 743         sv_setiv(sv, (IV)PL_maxsysfd);
 744         break;
 745     case '\010':                /* ^H */
 746         sv_setiv(sv, (IV)PL_hints);
 747         break;
 748     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 749         if (PL_inplace)
 750             sv_setpv(sv, PL_inplace);
 751         else
 752             sv_setsv(sv, &PL_sv_undef);
 753         break;
 754     case '\017':                /* ^O & ^OPEN */
 755         if (nextchar == '\0') {
 756             sv_setpv(sv, PL_osname);
 757             SvTAINTED_off(sv);
 758         }
 759         else if (strEQ(remaining, "PEN")) {
 760             if (!PL_compiling.cop_io)
 761                 sv_setsv(sv, &PL_sv_undef);
 762             else {
 763                 sv_setsv(sv, PL_compiling.cop_io);
 764             }
 765         }
 766         break;
 767     case '\020':                /* ^P */
 768         sv_setiv(sv, (IV)PL_perldb);
 769         break;
 770     case '\023':                /* ^S */
 771         if (nextchar == '\0') {
 772             if (PL_lex_state != LEX_NOTPARSING)
 773                 SvOK_off(sv);
 774             else if (PL_in_eval)
 775                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 776             else
 777                 sv_setiv(sv, 0);
 778         }
 779         break;
 780     case '\024':                /* ^T */
 781         if (nextchar == '\0') {
 782 #ifdef BIG_TIME
 783             sv_setnv(sv, PL_basetime);
 784 #else
 785             sv_setiv(sv, (IV)PL_basetime);
 786 #endif
 787         }
 788         else if (strEQ(remaining, "AINT"))
 789             sv_setiv(sv, PL_tainting
 790                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 791                     : 0);
 792         break;
 793     case '\025':                /* $^UNICODE, $^UTF8LOCALE */
 794         if (strEQ(remaining, "NICODE"))
 795             sv_setuv(sv, (UV) PL_unicode);
 796         else if (strEQ(remaining, "TF8LOCALE"))
 797             sv_setuv(sv, (UV) PL_utf8locale);
 798         break;
 799     case '\027':                /* ^W  & $^WARNING_BITS */
 800         if (nextchar == '\0')
 801             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 802         else if (strEQ(remaining, "ARNING_BITS")) {
 803             if (PL_compiling.cop_warnings == pWARN_NONE) {
 804                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 805             }
 806             else if (PL_compiling.cop_warnings == pWARN_STD) {
 807                 sv_setpvn(
 808                     sv,
 809                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 810                     WARNsize
 811                 );
 812             }
 813             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 814                 /* Get the bit mask for $warnings::Bits{all}, because
 815                  * it could have been extended by warnings::register */
 816                 SV **bits_all;
 817                 HV * const bits=get_hv("warnings::Bits", FALSE);
 818                 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
 819                     sv_setsv(sv, *bits_all);
 820                 }
 821                 else {
 822                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 823                 }
 824             }
 825             else {
 826                 sv_setsv(sv, PL_compiling.cop_warnings);
 827             }
 828             SvPOK_only(sv);
 829         }
 830         break;
 831     case '1': case '2': case '3': case '4':
 832     case '5': case '6': case '7': case '8': case '9': case '&':
 833         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 834             I32 s1, t1;
 835
 836             /*
 837              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 838              * XXX Does the new way break anything?
 839              */
 840             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 841           getparen:
 842             if (paren <= (I32)rx->nparens &&
 843                 (s1 = rx->startp[paren]) != -1 &&
 844                 (t1 = rx->endp[paren]) != -1)
 845             {
 846                 i = t1 - s1;
 847                 s = rx->subbeg + s1;
 848                 assert(rx->subbeg);
 849
 850               getrx:
 851                 if (i >= 0) {
 852                     const int oldtainted = PL_tainted;
 853                     TAINT_NOT;
 854                     sv_setpvn(sv, s, i);
 855                     PL_tainted = oldtainted;
 856                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 857                         SvUTF8_on(sv);
 858                     else
 859                         SvUTF8_off(sv);
 860                     if (PL_tainting) {
 861                         if (RX_MATCH_TAINTED(rx)) {
 862                             MAGIC* const mg = SvMAGIC(sv);
 863                             MAGIC* mgt;
 864                             PL_tainted = 1;
 865                             SvMAGIC_set(sv, mg->mg_moremagic);
 866                             SvTAINT(sv);
 867                             if ((mgt = SvMAGIC(sv))) {
 868                                 mg->mg_moremagic = mgt;
 869                                 SvMAGIC_set(sv, mg);
 870                             }
 871                         } else
 872                             SvTAINTED_off(sv);
 873                     }
 874                     break;
 875                 }
 876             }
 877         }
 878         sv_setsv(sv,&PL_sv_undef);
 879         break;
 880     case '+':
 881         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 882             paren = rx->lastparen;
 883             if (paren)
 884                 goto getparen;
 885         }
 886         sv_setsv(sv,&PL_sv_undef);
 887         break;
 888     case '\016':                /* ^N */
 889         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 890             paren = rx->lastcloseparen;
 891             if (paren)
 892                 goto getparen;
 893         }
 894         sv_setsv(sv,&PL_sv_undef);
 895         break;
 896     case '`':
 897         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 898             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 899                 i = rx->startp[0];
 900                 goto getrx;
 901             }
 902         }
 903         sv_setsv(sv,&PL_sv_undef);
 904         break;
 905     case '\'':
 906         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 907             if (rx->subbeg && rx->endp[0] != -1) {
 908                 s = rx->subbeg + rx->endp[0];
 909                 i = rx->sublen - rx->endp[0];
 910                 goto getrx;
 911             }
 912         }
 913         sv_setsv(sv,&PL_sv_undef);
 914         break;
 915     case '.':
 916         if (GvIO(PL_last_in_gv)) {
 917             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 918         }
 919         break;
 920     case '?':
 921         {
 922             sv_setiv(sv, (IV)STATUS_CURRENT);
 923 #ifdef COMPLEX_STATUS
 924             LvTARGOFF(sv) = PL_statusvalue;
 925             LvTARGLEN(sv) = PL_statusvalue_vms;
 926 #endif
 927         }
 928         break;
 929     case '^':
 930         if (GvIOp(PL_defoutgv))
 931             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 932         if (s)
 933             sv_setpv(sv,s);
 934         else {
 935             sv_setpv(sv,GvENAME(PL_defoutgv));
 936             sv_catpv(sv,"_TOP");
 937         }
 938         break;
 939     case '~':
 940         if (GvIOp(PL_defoutgv))
 941             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 942         if (!s)
 943             s = GvENAME(PL_defoutgv);
 944         sv_setpv(sv,s);
 945         break;
 946     case '=':
 947         if (GvIOp(PL_defoutgv))
 948             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 949         break;
 950     case '-':
 951         if (GvIOp(PL_defoutgv))
 952             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 953         break;
 954     case '%':
 955         if (GvIOp(PL_defoutgv))
 956             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 957         break;
 958     case ':':
 959         break;
 960     case '/':
 961         break;
 962     case '[':
 963         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 964         break;
 965     case '|':
 966         if (GvIOp(PL_defoutgv))
 967             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 968         break;
 969     case ',':
 970         break;
 971     case '\\':
 972         if (PL_ors_sv)
 973             sv_copypv(sv, PL_ors_sv);
 974         break;
 975     case '!':
 976 #ifdef VMS
 977         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 978         sv_setpv(sv, errno ? Strerror(errno) : "");
 979 #else
 980         {
 981         const int saveerrno = errno;
 982         sv_setnv(sv, (NV)errno);
 983 #ifdef OS2
 984         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 985             sv_setpv(sv, os2error(Perl_rc));
 986         else
 987 #endif
 988         sv_setpv(sv, errno ? Strerror(errno) : "");
 989         errno = saveerrno;
 990         }
 991 #endif
 992         SvRTRIM(sv);
 993         SvNOK_on(sv);   /* what a wonderful hack! */
 994         break;
 995     case '<':
 996         sv_setiv(sv, (IV)PL_uid);
 997         break;
 998     case '>':
 999         sv_setiv(sv, (IV)PL_euid);
1000         break;
1001     case '(':
1002         sv_setiv(sv, (IV)PL_gid);
1003         goto add_groups;
1004     case ')':
1005         sv_setiv(sv, (IV)PL_egid);
1006       add_groups:
1007 #ifdef HAS_GETGROUPS
1008         {
1009             Groups_t *gary = NULL;
1010             I32 i, num_groups = getgroups(0, gary);
1011             Newx(gary, num_groups, Groups_t);
1012             num_groups = getgroups(num_groups, gary);
1013             for (i = 0; i < num_groups; i++)
1014                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1015             Safefree(gary);
1016         }
1017         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1018 #endif
1019         break;
1020 #ifndef MACOS_TRADITIONAL
1021     case '0':
1022         break;
1023 #endif
1024     }
1025     return 0;
1026 }
1027
1028 int
1029 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1030 {
1031     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1032
1033     if (uf && uf->uf_val)
1034         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1035     return 0;
1036 }
1037
1038 int
1039 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1040 {
1041     dVAR;
1042     STRLEN len, klen;
1043     const char *s = SvPV_const(sv,len);
1044     const char * const ptr = MgPV_const(mg,klen);
1045     my_setenv(ptr, s);
1046
1047 #ifdef DYNAMIC_ENV_FETCH
1048      /* We just undefd an environment var.  Is a replacement */
1049      /* waiting in the wings? */
1050     if (!len) {
1051         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1052         if (valp)
1053             s = SvPV_const(*valp, len);
1054     }
1055 #endif
1056
1057 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1058                             /* And you'll never guess what the dog had */
1059                             /*   in its mouth... */
1060     if (PL_tainting) {
1061         MgTAINTEDDIR_off(mg);
1062 #ifdef VMS
1063         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1064             char pathbuf[256], eltbuf[256], *cp, *elt;
1065             Stat_t sbuf;
1066             int i = 0, j = 0;
1067
1068             strncpy(eltbuf, s, 255);
1069             eltbuf[255] = 0;
1070             elt = eltbuf;
1071             do {          /* DCL$PATH may be a search list */
1072                 while (1) {   /* as may dev portion of any element */
1073                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1074                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1075                              cando_by_name(S_IWUSR,0,elt) ) {
1076                             MgTAINTEDDIR_on(mg);
1077                             return 0;
1078                         }
1079                     }
1080                     if ((cp = strchr(elt, ':')) != NULL)
1081                         *cp = '\0';
1082                     if (my_trnlnm(elt, eltbuf, j++))
1083                         elt = eltbuf;
1084                     else
1085                         break;
1086                 }
1087                 j = 0;
1088             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1089         }
1090 #endif /* VMS */
1091         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1092             const char * const strend = s + len;
1093
1094             while (s < strend) {
1095                 char tmpbuf[256];
1096                 Stat_t st;
1097                 I32 i;
1098                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1099                              s, strend, ':', &i);
1100                 s++;
1101                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1102                       || *tmpbuf != '/'
1103                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1104                     MgTAINTEDDIR_on(mg);
1105                     return 0;
1106                 }
1107             }
1108         }
1109     }
1110 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1111
1112     return 0;
1113 }
1114
1115 int
1116 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1117 {
1118     PERL_UNUSED_ARG(sv);
1119     my_setenv(MgPV_nolen_const(mg),NULL);
1120     return 0;
1121 }
1122
1123 int
1124 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1125 {
1126     dVAR;
1127     PERL_UNUSED_ARG(mg);
1128 #if defined(VMS)
1129     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1130 #else
1131     if (PL_localizing) {
1132         HE* entry;
1133         my_clearenv();
1134         hv_iterinit((HV*)sv);
1135         while ((entry = hv_iternext((HV*)sv))) {
1136             I32 keylen;
1137             my_setenv(hv_iterkey(entry, &keylen),
1138                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1139         }
1140     }
1141 #endif
1142     return 0;
1143 }
1144
1145 int
1146 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1147 {
1148     dVAR;
1149     PERL_UNUSED_ARG(sv);
1150     PERL_UNUSED_ARG(mg);
1151 #if defined(VMS)
1152     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1153 #else
1154     my_clearenv();
1155 #endif
1156     return 0;
1157 }
1158
1159 #ifndef PERL_MICRO
1160 #ifdef HAS_SIGPROCMASK
1161 static void
1162 restore_sigmask(pTHX_ SV *save_sv)
1163 {
1164     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1165     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1166 }
1167 #endif
1168 int
1169 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1170 {
1171     dVAR;
1172     /* Are we fetching a signal entry? */
1173     const I32 i = whichsig(MgPV_nolen_const(mg));
1174     if (i > 0) {
1175         if(PL_psig_ptr[i])
1176             sv_setsv(sv,PL_psig_ptr[i]);
1177         else {
1178             Sighandler_t sigstate;
1179             sigstate = rsignal_state(i);
1180 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1181             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1182 #endif
1183 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1184             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1185 #endif
1186             /* cache state so we don't fetch it again */
1187             if(sigstate == (Sighandler_t) SIG_IGN)
1188                 sv_setpv(sv,"IGNORE");
1189             else
1190                 sv_setsv(sv,&PL_sv_undef);
1191             PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1192             SvTEMP_off(sv);
1193         }
1194     }
1195     return 0;
1196 }
1197 int
1198 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1199 {
1200     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1201      * refactoring might be in order.
1202      */
1203     dVAR;
1204     register const char * const s = MgPV_nolen_const(mg);
1205     PERL_UNUSED_ARG(sv);
1206     if (*s == '_') {
1207         SV** svp = NULL;
1208         if (strEQ(s,"__DIE__"))
1209             svp = &PL_diehook;
1210         else if (strEQ(s,"__WARN__"))
1211             svp = &PL_warnhook;
1212         else
1213             Perl_croak(aTHX_ "No such hook: %s", s);
1214         if (svp && *svp) {
1215             SV * const to_dec = *svp;
1216             *svp = NULL;
1217             SvREFCNT_dec(to_dec);
1218         }
1219     }
1220     else {
1221         /* Are we clearing a signal entry? */
1222         const I32 i = whichsig(s);
1223         if (i > 0) {
1224 #ifdef HAS_SIGPROCMASK
1225             sigset_t set, save;
1226             SV* save_sv;
1227             /* Avoid having the signal arrive at a bad time, if possible. */
1228             sigemptyset(&set);
1229             sigaddset(&set,i);
1230             sigprocmask(SIG_BLOCK, &set, &save);
1231             ENTER;
1232             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1233             SAVEFREESV(save_sv);
1234             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1235 #endif
1236             PERL_ASYNC_CHECK();
1237 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1238             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1239 #endif
1240 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1241             PL_sig_defaulting[i] = 1;
1242             (void)rsignal(i, PL_csighandlerp);
1243 #else
1244             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1245 #endif
1246             if(PL_psig_name[i]) {
1247                 SvREFCNT_dec(PL_psig_name[i]);
1248                 PL_psig_name[i]=0;
1249             }
1250             if(PL_psig_ptr[i]) {
1251                 SV * const to_dec=PL_psig_ptr[i];
1252                 PL_psig_ptr[i]=0;
1253                 LEAVE;
1254                 SvREFCNT_dec(to_dec);
1255             }
1256             else
1257                 LEAVE;
1258         }
1259     }
1260     return 0;
1261 }
1262
1263 static void
1264 S_raise_signal(pTHX_ int sig)
1265 {
1266     dVAR;
1267     /* Set a flag to say this signal is pending */
1268     PL_psig_pend[sig]++;
1269     /* And one to say _a_ signal is pending */
1270     PL_sig_pending = 1;
1271 }
1272
1273 Signal_t
1274 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1275 Perl_csighandler(int sig, ...)
1276 #else
1277 Perl_csighandler(int sig)
1278 #endif
1279 {
1280 #ifdef PERL_GET_SIG_CONTEXT
1281     dTHXa(PERL_GET_SIG_CONTEXT);
1282 #else
1283     dTHX;
1284 #endif
1285 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1286     (void) rsignal(sig, PL_csighandlerp);
1287     if (PL_sig_ignoring[sig]) return;
1288 #endif
1289 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1290     if (PL_sig_defaulting[sig])
1291 #ifdef KILL_BY_SIGPRC
1292             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1293 #else
1294             exit(1);
1295 #endif
1296 #endif
1297    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1298         /* Call the perl level handler now--
1299          * with risk we may be in malloc() etc. */
1300         (*PL_sighandlerp)(sig);
1301    else
1302         S_raise_signal(aTHX_ sig);
1303 }
1304
1305 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1306 void
1307 Perl_csighandler_init(void)
1308 {
1309     int sig;
1310     if (PL_sig_handlers_initted) return;
1311
1312     for (sig = 1; sig < SIG_SIZE; sig++) {
1313 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1314         dTHX;
1315         PL_sig_defaulting[sig] = 1;
1316         (void) rsignal(sig, PL_csighandlerp);
1317 #endif
1318 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1319         PL_sig_ignoring[sig] = 0;
1320 #endif
1321     }
1322     PL_sig_handlers_initted = 1;
1323 }
1324 #endif
1325
1326 void
1327 Perl_despatch_signals(pTHX)
1328 {
1329     dVAR;
1330     int sig;
1331     PL_sig_pending = 0;
1332     for (sig = 1; sig < SIG_SIZE; sig++) {
1333         if (PL_psig_pend[sig]) {
1334             PERL_BLOCKSIG_ADD(set, sig);
1335             PL_psig_pend[sig] = 0;
1336             PERL_BLOCKSIG_BLOCK(set);
1337             (*PL_sighandlerp)(sig);
1338             PERL_BLOCKSIG_UNBLOCK(set);
1339         }
1340     }
1341 }
1342
1343 int
1344 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1345 {
1346     dVAR;
1347     I32 i;
1348     SV** svp = NULL;
1349     /* Need to be careful with SvREFCNT_dec(), because that can have side
1350      * effects (due to closures). We must make sure that the new disposition
1351      * is in place before it is called.
1352      */
1353     SV* to_dec = NULL;
1354     STRLEN len;
1355 #ifdef HAS_SIGPROCMASK
1356     sigset_t set, save;
1357     SV* save_sv;
1358 #endif
1359
1360     register const char *s = MgPV_const(mg,len);
1361     if (*s == '_') {
1362         if (strEQ(s,"__DIE__"))
1363             svp = &PL_diehook;
1364         else if (strEQ(s,"__WARN__"))
1365             svp = &PL_warnhook;
1366         else
1367             Perl_croak(aTHX_ "No such hook: %s", s);
1368         i = 0;
1369         if (*svp) {
1370             to_dec = *svp;
1371             *svp = NULL;
1372         }
1373     }
1374     else {
1375         i = whichsig(s);        /* ...no, a brick */
1376         if (i <= 0) {
1377             if (ckWARN(WARN_SIGNAL))
1378                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1379             return 0;
1380         }
1381 #ifdef HAS_SIGPROCMASK
1382         /* Avoid having the signal arrive at a bad time, if possible. */
1383         sigemptyset(&set);
1384         sigaddset(&set,i);
1385         sigprocmask(SIG_BLOCK, &set, &save);
1386         ENTER;
1387         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1388         SAVEFREESV(save_sv);
1389         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1390 #endif
1391         PERL_ASYNC_CHECK();
1392 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1393         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1394 #endif
1395 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1396         PL_sig_ignoring[i] = 0;
1397 #endif
1398 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1399         PL_sig_defaulting[i] = 0;
1400 #endif
1401         SvREFCNT_dec(PL_psig_name[i]);
1402         to_dec = PL_psig_ptr[i];
1403         PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1404         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1405         PL_psig_name[i] = newSVpvn(s, len);
1406         SvREADONLY_on(PL_psig_name[i]);
1407     }
1408     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1409         if (i) {
1410             (void)rsignal(i, PL_csighandlerp);
1411 #ifdef HAS_SIGPROCMASK
1412             LEAVE;
1413 #endif
1414         }
1415         else
1416             *svp = SvREFCNT_inc_simple_NN(sv);
1417         if(to_dec)
1418             SvREFCNT_dec(to_dec);
1419         return 0;
1420     }
1421     s = SvPV_force(sv,len);
1422     if (strEQ(s,"IGNORE")) {
1423         if (i) {
1424 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1425             PL_sig_ignoring[i] = 1;
1426             (void)rsignal(i, PL_csighandlerp);
1427 #else
1428             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1429 #endif
1430         }
1431     }
1432     else if (strEQ(s,"DEFAULT") || !*s) {
1433         if (i)
1434 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1435           {
1436             PL_sig_defaulting[i] = 1;
1437             (void)rsignal(i, PL_csighandlerp);
1438           }
1439 #else
1440             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1441 #endif
1442     }
1443     else {
1444         /*
1445          * We should warn if HINT_STRICT_REFS, but without
1446          * access to a known hint bit in a known OP, we can't
1447          * tell whether HINT_STRICT_REFS is in force or not.
1448          */
1449         if (!strchr(s,':') && !strchr(s,'\''))
1450             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1451         if (i)
1452             (void)rsignal(i, PL_csighandlerp);
1453         else
1454             *svp = SvREFCNT_inc_simple(sv);
1455     }
1456 #ifdef HAS_SIGPROCMASK
1457     if(i)
1458         LEAVE;
1459 #endif
1460     if(to_dec)
1461         SvREFCNT_dec(to_dec);
1462     return 0;
1463 }
1464 #endif /* !PERL_MICRO */
1465
1466 int
1467 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1468 {
1469     dVAR;
1470     PERL_UNUSED_ARG(sv);
1471     PERL_UNUSED_ARG(mg);
1472     PL_sub_generation++;
1473     return 0;
1474 }
1475
1476 int
1477 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1478 {
1479     dVAR;
1480     PERL_UNUSED_ARG(sv);
1481     PERL_UNUSED_ARG(mg);
1482     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1483     PL_amagic_generation++;
1484
1485     return 0;
1486 }
1487
1488 int
1489 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1490 {
1491     HV * const hv = (HV*)LvTARG(sv);
1492     I32 i = 0;
1493     PERL_UNUSED_ARG(mg);
1494
1495     if (hv) {
1496          (void) hv_iterinit(hv);
1497          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1498              i = HvKEYS(hv);
1499          else {
1500              while (hv_iternext(hv))
1501                  i++;
1502          }
1503     }
1504
1505     sv_setiv(sv, (IV)i);
1506     return 0;
1507 }
1508
1509 int
1510 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1511 {
1512     PERL_UNUSED_ARG(mg);
1513     if (LvTARG(sv)) {
1514         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1515     }
1516     return 0;
1517 }
1518
1519 /* caller is responsible for stack switching/cleanup */
1520 STATIC int
1521 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1522 {
1523     dVAR;
1524     dSP;
1525
1526     PUSHMARK(SP);
1527     EXTEND(SP, n);
1528     PUSHs(SvTIED_obj(sv, mg));
1529     if (n > 1) {
1530         if (mg->mg_ptr) {
1531             if (mg->mg_len >= 0)
1532                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1533             else if (mg->mg_len == HEf_SVKEY)
1534                 PUSHs((SV*)mg->mg_ptr);
1535         }
1536         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1537             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1538         }
1539     }
1540     if (n > 2) {
1541         PUSHs(val);
1542     }
1543     PUTBACK;
1544
1545     return call_method(meth, flags);
1546 }
1547
1548 STATIC int
1549 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1550 {
1551     dVAR; dSP;
1552
1553     ENTER;
1554     SAVETMPS;
1555     PUSHSTACKi(PERLSI_MAGIC);
1556
1557     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1558         sv_setsv(sv, *PL_stack_sp--);
1559     }
1560
1561     POPSTACK;
1562     FREETMPS;
1563     LEAVE;
1564     return 0;
1565 }
1566
1567 int
1568 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1569 {
1570     if (mg->mg_ptr)
1571         mg->mg_flags |= MGf_GSKIP;
1572     magic_methpack(sv,mg,"FETCH");
1573     return 0;
1574 }
1575
1576 int
1577 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1578 {
1579     dVAR; dSP;
1580     ENTER;
1581     PUSHSTACKi(PERLSI_MAGIC);
1582     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1583     POPSTACK;
1584     LEAVE;
1585     return 0;
1586 }
1587
1588 int
1589 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1590 {
1591     return magic_methpack(sv,mg,"DELETE");
1592 }
1593
1594
1595 U32
1596 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1597 {
1598     dVAR; dSP;
1599     U32 retval = 0;
1600
1601     ENTER;
1602     SAVETMPS;
1603     PUSHSTACKi(PERLSI_MAGIC);
1604     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1605         sv = *PL_stack_sp--;
1606         retval = (U32) SvIV(sv)-1;
1607     }
1608     POPSTACK;
1609     FREETMPS;
1610     LEAVE;
1611     return retval;
1612 }
1613
1614 int
1615 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1616 {
1617     dVAR; dSP;
1618
1619     ENTER;
1620     PUSHSTACKi(PERLSI_MAGIC);
1621     PUSHMARK(SP);
1622     XPUSHs(SvTIED_obj(sv, mg));
1623     PUTBACK;
1624     call_method("CLEAR", G_SCALAR|G_DISCARD);
1625     POPSTACK;
1626     LEAVE;
1627
1628     return 0;
1629 }
1630
1631 int
1632 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1633 {
1634     dVAR; dSP;
1635     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1636
1637     ENTER;
1638     SAVETMPS;
1639     PUSHSTACKi(PERLSI_MAGIC);
1640     PUSHMARK(SP);
1641     EXTEND(SP, 2);
1642     PUSHs(SvTIED_obj(sv, mg));
1643     if (SvOK(key))
1644         PUSHs(key);
1645     PUTBACK;
1646
1647     if (call_method(meth, G_SCALAR))
1648         sv_setsv(key, *PL_stack_sp--);
1649
1650     POPSTACK;
1651     FREETMPS;
1652     LEAVE;
1653     return 0;
1654 }
1655
1656 int
1657 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1658 {
1659     return magic_methpack(sv,mg,"EXISTS");
1660 }
1661
1662 SV *
1663 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1664 {
1665     dVAR; dSP;
1666     SV *retval = &PL_sv_undef;
1667     SV * const tied = SvTIED_obj((SV*)hv, mg);
1668     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1669
1670     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1671         SV *key;
1672         if (HvEITER_get(hv))
1673             /* we are in an iteration so the hash cannot be empty */
1674             return &PL_sv_yes;
1675         /* no xhv_eiter so now use FIRSTKEY */
1676         key = sv_newmortal();
1677         magic_nextpack((SV*)hv, mg, key);
1678         HvEITER_set(hv, NULL);     /* need to reset iterator */
1679         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1680     }
1681
1682     /* there is a SCALAR method that we can call */
1683     ENTER;
1684     PUSHSTACKi(PERLSI_MAGIC);
1685     PUSHMARK(SP);
1686     EXTEND(SP, 1);
1687     PUSHs(tied);
1688     PUTBACK;
1689
1690     if (call_method("SCALAR", G_SCALAR))
1691         retval = *PL_stack_sp--;
1692     POPSTACK;
1693     LEAVE;
1694     return retval;
1695 }
1696
1697 int
1698 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1699 {
1700     dVAR;
1701     GV * const gv = PL_DBline;
1702     const I32 i = SvTRUE(sv);
1703     SV ** const svp = av_fetch(GvAV(gv),
1704                      atoi(MgPV_nolen_const(mg)), FALSE);
1705     if (svp && SvIOKp(*svp)) {
1706         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1707         if (o) {
1708             /* set or clear breakpoint in the relevant control op */
1709             if (i)
1710                 o->op_flags |= OPf_SPECIAL;
1711             else
1712                 o->op_flags &= ~OPf_SPECIAL;
1713         }
1714     }
1715     return 0;
1716 }
1717
1718 int
1719 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1720 {
1721     dVAR;
1722     const AV * const obj = (AV*)mg->mg_obj;
1723     if (obj) {
1724         sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1725     } else {
1726         SvOK_off(sv);
1727     }
1728     return 0;
1729 }
1730
1731 int
1732 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1733 {
1734     dVAR;
1735     AV * const obj = (AV*)mg->mg_obj;
1736     if (obj) {
1737         av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1738     } else {
1739         if (ckWARN(WARN_MISC))
1740             Perl_warner(aTHX_ packWARN(WARN_MISC),
1741                         "Attempt to set length of freed array");
1742     }
1743     return 0;
1744 }
1745
1746 int
1747 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1748 {
1749     dVAR;
1750     PERL_UNUSED_ARG(sv);
1751     /* during global destruction, mg_obj may already have been freed */
1752     if (PL_in_clean_all)
1753         return 0;
1754
1755     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1756
1757     if (mg) {
1758         /* arylen scalar holds a pointer back to the array, but doesn't own a
1759            reference. Hence the we (the array) are about to go away with it
1760            still pointing at us. Clear its pointer, else it would be pointing
1761            at free memory. See the comment in sv_magic about reference loops,
1762            and why it can't own a reference to us.  */
1763         mg->mg_obj = 0;
1764     }
1765     return 0;
1766 }
1767
1768 int
1769 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1770 {
1771     dVAR;
1772     SV* const lsv = LvTARG(sv);
1773
1774     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1775         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1776         if (mg && mg->mg_len >= 0) {
1777             I32 i = mg->mg_len;
1778             if (DO_UTF8(lsv))
1779                 sv_pos_b2u(lsv, &i);
1780             sv_setiv(sv, i + PL_curcop->cop_arybase);
1781             return 0;
1782         }
1783     }
1784     SvOK_off(sv);
1785     return 0;
1786 }
1787
1788 int
1789 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1790 {
1791     dVAR;
1792     SV* const lsv = LvTARG(sv);
1793     SSize_t pos;
1794     STRLEN len;
1795     STRLEN ulen = 0;
1796
1797     mg = 0;
1798
1799     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1800         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1801     if (!mg) {
1802         if (!SvOK(sv))
1803             return 0;
1804         sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1805         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1806     }
1807     else if (!SvOK(sv)) {
1808         mg->mg_len = -1;
1809         return 0;
1810     }
1811     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1812
1813     pos = SvIV(sv) - PL_curcop->cop_arybase;
1814
1815     if (DO_UTF8(lsv)) {
1816         ulen = sv_len_utf8(lsv);
1817         if (ulen)
1818             len = ulen;
1819     }
1820
1821     if (pos < 0) {
1822         pos += len;
1823         if (pos < 0)
1824             pos = 0;
1825     }
1826     else if (pos > (SSize_t)len)
1827         pos = len;
1828
1829     if (ulen) {
1830         I32 p = pos;
1831         sv_pos_u2b(lsv, &p, 0);
1832         pos = p;
1833     }
1834
1835     mg->mg_len = pos;
1836     mg->mg_flags &= ~MGf_MINMATCH;
1837
1838     return 0;
1839 }
1840
1841 int
1842 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1843 {
1844     GV* gv;
1845     PERL_UNUSED_ARG(mg);
1846
1847     if (!SvOK(sv))
1848         return 0;
1849     if (SvFLAGS(sv) & SVp_SCREAM
1850         && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1851         /* We're actually already a typeglob, so don't need the stuff below.
1852          */
1853         return 0;
1854     }
1855     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1856     if (sv == (SV*)gv)
1857         return 0;
1858     if (GvGP(sv))
1859         gp_free((GV*)sv);
1860     GvGP(sv) = gp_ref(GvGP(gv));
1861     return 0;
1862 }
1863
1864 int
1865 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1866 {
1867     STRLEN len;
1868     SV * const lsv = LvTARG(sv);
1869     const char * const tmps = SvPV_const(lsv,len);
1870     I32 offs = LvTARGOFF(sv);
1871     I32 rem = LvTARGLEN(sv);
1872     PERL_UNUSED_ARG(mg);
1873
1874     if (SvUTF8(lsv))
1875         sv_pos_u2b(lsv, &offs, &rem);
1876     if (offs > (I32)len)
1877         offs = len;
1878     if (rem + offs > (I32)len)
1879         rem = len - offs;
1880     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1881     if (SvUTF8(lsv))
1882         SvUTF8_on(sv);
1883     return 0;
1884 }
1885
1886 int
1887 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1888 {
1889     dVAR;
1890     STRLEN len;
1891     const char *tmps = SvPV_const(sv, len);
1892     SV * const lsv = LvTARG(sv);
1893     I32 lvoff = LvTARGOFF(sv);
1894     I32 lvlen = LvTARGLEN(sv);
1895     PERL_UNUSED_ARG(mg);
1896
1897     if (DO_UTF8(sv)) {
1898         sv_utf8_upgrade(lsv);
1899         sv_pos_u2b(lsv, &lvoff, &lvlen);
1900         sv_insert(lsv, lvoff, lvlen, tmps, len);
1901         LvTARGLEN(sv) = sv_len_utf8(sv);
1902         SvUTF8_on(lsv);
1903     }
1904     else if (lsv && SvUTF8(lsv)) {
1905         sv_pos_u2b(lsv, &lvoff, &lvlen);
1906         LvTARGLEN(sv) = len;
1907         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1908         sv_insert(lsv, lvoff, lvlen, tmps, len);
1909         Safefree(tmps);
1910     }
1911     else {
1912         sv_insert(lsv, lvoff, lvlen, tmps, len);
1913         LvTARGLEN(sv) = len;
1914     }
1915
1916
1917     return 0;
1918 }
1919
1920 int
1921 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1922 {
1923     dVAR;
1924     PERL_UNUSED_ARG(sv);
1925     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1926     return 0;
1927 }
1928
1929 int
1930 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1931 {
1932     dVAR;
1933     PERL_UNUSED_ARG(sv);
1934     /* update taint status unless we're restoring at scope exit */
1935     if (PL_localizing != 2) {
1936         if (PL_tainted)
1937             mg->mg_len |= 1;
1938         else
1939             mg->mg_len &= ~1;
1940     }
1941     return 0;
1942 }
1943
1944 int
1945 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1946 {
1947     SV * const lsv = LvTARG(sv);
1948     PERL_UNUSED_ARG(mg);
1949
1950     if (lsv)
1951         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1952     else
1953         SvOK_off(sv);
1954
1955     return 0;
1956 }
1957
1958 int
1959 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1960 {
1961     PERL_UNUSED_ARG(mg);
1962     do_vecset(sv);      /* XXX slurp this routine */
1963     return 0;
1964 }
1965
1966 int
1967 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1968 {
1969     dVAR;
1970     SV *targ = NULL;
1971     if (LvTARGLEN(sv)) {
1972         if (mg->mg_obj) {
1973             SV * const ahv = LvTARG(sv);
1974             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1975             if (he)
1976                 targ = HeVAL(he);
1977         }
1978         else {
1979             AV* const av = (AV*)LvTARG(sv);
1980             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1981                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1982         }
1983         if (targ && targ != &PL_sv_undef) {
1984             /* somebody else defined it for us */
1985             SvREFCNT_dec(LvTARG(sv));
1986             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
1987             LvTARGLEN(sv) = 0;
1988             SvREFCNT_dec(mg->mg_obj);
1989             mg->mg_obj = NULL;
1990             mg->mg_flags &= ~MGf_REFCOUNTED;
1991         }
1992     }
1993     else
1994         targ = LvTARG(sv);
1995     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1996     return 0;
1997 }
1998
1999 int
2000 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2001 {
2002     PERL_UNUSED_ARG(mg);
2003     if (LvTARGLEN(sv))
2004         vivify_defelem(sv);
2005     if (LvTARG(sv)) {
2006         sv_setsv(LvTARG(sv), sv);
2007         SvSETMAGIC(LvTARG(sv));
2008     }
2009     return 0;
2010 }
2011
2012 void
2013 Perl_vivify_defelem(pTHX_ SV *sv)
2014 {
2015     dVAR;
2016     MAGIC *mg;
2017     SV *value = NULL;
2018
2019     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2020         return;
2021     if (mg->mg_obj) {
2022         SV * const ahv = LvTARG(sv);
2023         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2024         if (he)
2025             value = HeVAL(he);
2026         if (!value || value == &PL_sv_undef)
2027             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2028     }
2029     else {
2030         AV* const av = (AV*)LvTARG(sv);
2031         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2032             LvTARG(sv) = NULL;  /* array can't be extended */
2033         else {
2034             SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2035             if (!svp || (value = *svp) == &PL_sv_undef)
2036                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2037         }
2038     }
2039     SvREFCNT_inc_simple_void(value);
2040     SvREFCNT_dec(LvTARG(sv));
2041     LvTARG(sv) = value;
2042     LvTARGLEN(sv) = 0;
2043     SvREFCNT_dec(mg->mg_obj);
2044     mg->mg_obj = NULL;
2045     mg->mg_flags &= ~MGf_REFCOUNTED;
2046 }
2047
2048 int
2049 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2050 {
2051     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2052 }
2053
2054 int
2055 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2056 {
2057     PERL_UNUSED_CONTEXT;
2058     mg->mg_len = -1;
2059     SvSCREAM_off(sv);
2060     return 0;
2061 }
2062
2063 int
2064 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2065 {
2066     PERL_UNUSED_ARG(mg);
2067     sv_unmagic(sv, PERL_MAGIC_bm);
2068     SvVALID_off(sv);
2069     return 0;
2070 }
2071
2072 int
2073 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2074 {
2075     PERL_UNUSED_ARG(mg);
2076     sv_unmagic(sv, PERL_MAGIC_fm);
2077     SvCOMPILED_off(sv);
2078     return 0;
2079 }
2080
2081 int
2082 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2083 {
2084     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2085
2086     if (uf && uf->uf_set)
2087         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2088     return 0;
2089 }
2090
2091 int
2092 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2093 {
2094     PERL_UNUSED_ARG(mg);
2095     sv_unmagic(sv, PERL_MAGIC_qr);
2096     return 0;
2097 }
2098
2099 int
2100 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2101 {
2102     dVAR;
2103     regexp * const re = (regexp *)mg->mg_obj;
2104     PERL_UNUSED_ARG(sv);
2105
2106     ReREFCNT_dec(re);
2107     return 0;
2108 }
2109
2110 #ifdef USE_LOCALE_COLLATE
2111 int
2112 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2113 {
2114     /*
2115      * RenE<eacute> Descartes said "I think not."
2116      * and vanished with a faint plop.
2117      */
2118     PERL_UNUSED_CONTEXT;
2119     PERL_UNUSED_ARG(sv);
2120     if (mg->mg_ptr) {
2121         Safefree(mg->mg_ptr);
2122         mg->mg_ptr = NULL;
2123         mg->mg_len = -1;
2124     }
2125     return 0;
2126 }
2127 #endif /* USE_LOCALE_COLLATE */
2128
2129 /* Just clear the UTF-8 cache data. */
2130 int
2131 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2132 {
2133     PERL_UNUSED_CONTEXT;
2134     PERL_UNUSED_ARG(sv);
2135     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2136     mg->mg_ptr = 0;
2137     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2138     return 0;
2139 }
2140
2141 int
2142 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2143 {
2144     dVAR;
2145     register const char *s;
2146     I32 i;
2147     STRLEN len;
2148     switch (*mg->mg_ptr) {
2149     case '\001':        /* ^A */
2150         sv_setsv(PL_bodytarget, sv);
2151         break;
2152     case '\003':        /* ^C */
2153         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2154         break;
2155
2156     case '\004':        /* ^D */
2157 #ifdef DEBUGGING
2158         s = SvPV_nolen_const(sv);
2159         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2160         DEBUG_x(dump_all());
2161 #else
2162         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2163 #endif
2164         break;
2165     case '\005':  /* ^E */
2166         if (*(mg->mg_ptr+1) == '\0') {
2167 #ifdef MACOS_TRADITIONAL
2168             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2169 #else
2170 #  ifdef VMS
2171             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2172 #  else
2173 #    ifdef WIN32
2174             SetLastError( SvIV(sv) );
2175 #    else
2176 #      ifdef OS2
2177             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2178 #      else
2179             /* will anyone ever use this? */
2180             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2181 #      endif
2182 #    endif
2183 #  endif
2184 #endif
2185         }
2186         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2187             if (PL_encoding)
2188                 SvREFCNT_dec(PL_encoding);
2189             if (SvOK(sv) || SvGMAGICAL(sv)) {
2190                 PL_encoding = newSVsv(sv);
2191             }
2192             else {
2193                 PL_encoding = NULL;
2194             }
2195         }
2196         break;
2197     case '\006':        /* ^F */
2198         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2199         break;
2200     case '\010':        /* ^H */
2201         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2202         break;
2203     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2204         Safefree(PL_inplace);
2205         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2206         break;
2207     case '\017':        /* ^O */
2208         if (*(mg->mg_ptr+1) == '\0') {
2209             Safefree(PL_osname);
2210             PL_osname = NULL;
2211             if (SvOK(sv)) {
2212                 TAINT_PROPER("assigning to $^O");
2213                 PL_osname = savesvpv(sv);
2214             }
2215         }
2216         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2217             if (!PL_compiling.cop_io)
2218                 PL_compiling.cop_io = newSVsv(sv);
2219             else
2220                 sv_setsv(PL_compiling.cop_io,sv);
2221         }
2222         break;
2223     case '\020':        /* ^P */
2224         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2225         if (PL_perldb && !PL_DBsingle)
2226             init_debugger();
2227         break;
2228     case '\024':        /* ^T */
2229 #ifdef BIG_TIME
2230         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2231 #else
2232         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2233 #endif
2234         break;
2235     case '\027':        /* ^W & $^WARNING_BITS */
2236         if (*(mg->mg_ptr+1) == '\0') {
2237             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2238                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2239                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2240                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2241             }
2242         }
2243         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2244             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2245                 if (!SvPOK(sv) && PL_localizing) {
2246                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2247                     PL_compiling.cop_warnings = pWARN_NONE;
2248                     break;
2249                 }
2250                 {
2251                     STRLEN len, i;
2252                     int accumulate = 0 ;
2253                     int any_fatals = 0 ;
2254                     const char * const ptr = SvPV_const(sv, len) ;
2255                     for (i = 0 ; i < len ; ++i) {
2256                         accumulate |= ptr[i] ;
2257                         any_fatals |= (ptr[i] & 0xAA) ;
2258                     }
2259                     if (!accumulate)
2260                         PL_compiling.cop_warnings = pWARN_NONE;
2261                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2262                         PL_compiling.cop_warnings = pWARN_ALL;
2263                         PL_dowarn |= G_WARN_ONCE ;
2264                     }
2265                     else {
2266                         if (specialWARN(PL_compiling.cop_warnings))
2267                             PL_compiling.cop_warnings = newSVsv(sv) ;
2268                         else
2269                             sv_setsv(PL_compiling.cop_warnings, sv);
2270                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2271                             PL_dowarn |= G_WARN_ONCE ;
2272                     }
2273
2274                 }
2275             }
2276         }
2277         break;
2278     case '.':
2279         if (PL_localizing) {
2280             if (PL_localizing == 1)
2281                 SAVESPTR(PL_last_in_gv);
2282         }
2283         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2284             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2285         break;
2286     case '^':
2287         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2288         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2289         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2290         break;
2291     case '~':
2292         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2293         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2294         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2295         break;
2296     case '=':
2297         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2298         break;
2299     case '-':
2300         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2301         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2302             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2303         break;
2304     case '%':
2305         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2306         break;
2307     case '|':
2308         {
2309             IO * const io = GvIOp(PL_defoutgv);
2310             if(!io)
2311               break;
2312             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2313                 IoFLAGS(io) &= ~IOf_FLUSH;
2314             else {
2315                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2316                     PerlIO *ofp = IoOFP(io);
2317                     if (ofp)
2318                         (void)PerlIO_flush(ofp);
2319                     IoFLAGS(io) |= IOf_FLUSH;
2320                 }
2321             }
2322         }
2323         break;
2324     case '/':
2325         SvREFCNT_dec(PL_rs);
2326         PL_rs = newSVsv(sv);
2327         break;
2328     case '\\':
2329         if (PL_ors_sv)
2330             SvREFCNT_dec(PL_ors_sv);
2331         if (SvOK(sv) || SvGMAGICAL(sv)) {
2332             PL_ors_sv = newSVsv(sv);
2333         }
2334         else {
2335             PL_ors_sv = NULL;
2336         }
2337         break;
2338     case ',':
2339         if (PL_ofs_sv)
2340             SvREFCNT_dec(PL_ofs_sv);
2341         if (SvOK(sv) || SvGMAGICAL(sv)) {
2342             PL_ofs_sv = newSVsv(sv);
2343         }
2344         else {
2345             PL_ofs_sv = NULL;
2346         }
2347         break;
2348     case '[':
2349         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2350         break;
2351     case '?':
2352 #ifdef COMPLEX_STATUS
2353         if (PL_localizing == 2) {
2354             PL_statusvalue = LvTARGOFF(sv);
2355             PL_statusvalue_vms = LvTARGLEN(sv);
2356         }
2357         else
2358 #endif
2359 #ifdef VMSISH_STATUS
2360         if (VMSISH_STATUS)
2361             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2362         else
2363 #endif
2364             STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2365         break;
2366     case '!':
2367         {
2368 #ifdef VMS
2369 #   define PERL_VMS_BANG vaxc$errno
2370 #else
2371 #   define PERL_VMS_BANG 0
2372 #endif
2373         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2374                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2375         }
2376         break;
2377     case '<':
2378         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2379         if (PL_delaymagic) {
2380             PL_delaymagic |= DM_RUID;
2381             break;                              /* don't do magic till later */
2382         }
2383 #ifdef HAS_SETRUID
2384         (void)setruid((Uid_t)PL_uid);
2385 #else
2386 #ifdef HAS_SETREUID
2387         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2388 #else
2389 #ifdef HAS_SETRESUID
2390       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2391 #else
2392         if (PL_uid == PL_euid) {                /* special case $< = $> */
2393 #ifdef PERL_DARWIN
2394             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2395             if (PL_uid != 0 && PerlProc_getuid() == 0)
2396                 (void)PerlProc_setuid(0);
2397 #endif
2398             (void)PerlProc_setuid(PL_uid);
2399         } else {
2400             PL_uid = PerlProc_getuid();
2401             Perl_croak(aTHX_ "setruid() not implemented");
2402         }
2403 #endif
2404 #endif
2405 #endif
2406         PL_uid = PerlProc_getuid();
2407         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2408         break;
2409     case '>':
2410         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2411         if (PL_delaymagic) {
2412             PL_delaymagic |= DM_EUID;
2413             break;                              /* don't do magic till later */
2414         }
2415 #ifdef HAS_SETEUID
2416         (void)seteuid((Uid_t)PL_euid);
2417 #else
2418 #ifdef HAS_SETREUID
2419         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2420 #else
2421 #ifdef HAS_SETRESUID
2422         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2423 #else
2424         if (PL_euid == PL_uid)          /* special case $> = $< */
2425             PerlProc_setuid(PL_euid);
2426         else {
2427             PL_euid = PerlProc_geteuid();
2428             Perl_croak(aTHX_ "seteuid() not implemented");
2429         }
2430 #endif
2431 #endif
2432 #endif
2433         PL_euid = PerlProc_geteuid();
2434         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2435         break;
2436     case '(':
2437         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2438         if (PL_delaymagic) {
2439             PL_delaymagic |= DM_RGID;
2440             break;                              /* don't do magic till later */
2441         }
2442 #ifdef HAS_SETRGID
2443         (void)setrgid((Gid_t)PL_gid);
2444 #else
2445 #ifdef HAS_SETREGID
2446         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2447 #else
2448 #ifdef HAS_SETRESGID
2449       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2450 #else
2451         if (PL_gid == PL_egid)                  /* special case $( = $) */
2452             (void)PerlProc_setgid(PL_gid);
2453         else {
2454             PL_gid = PerlProc_getgid();
2455             Perl_croak(aTHX_ "setrgid() not implemented");
2456         }
2457 #endif
2458 #endif
2459 #endif
2460         PL_gid = PerlProc_getgid();
2461         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2462         break;
2463     case ')':
2464 #ifdef HAS_SETGROUPS
2465         {
2466             const char *p = SvPV_const(sv, len);
2467             Groups_t *gary = NULL;
2468
2469             while (isSPACE(*p))
2470                 ++p;
2471             PL_egid = Atol(p);
2472             for (i = 0; i < NGROUPS; ++i) {
2473                 while (*p && !isSPACE(*p))
2474                     ++p;
2475                 while (isSPACE(*p))
2476                     ++p;
2477                 if (!*p)
2478                     break;
2479                 if(!gary)
2480                     Newx(gary, i + 1, Groups_t);
2481                 else
2482                     Renew(gary, i + 1, Groups_t);
2483                 gary[i] = Atol(p);
2484             }
2485             if (i)
2486                 (void)setgroups(i, gary);
2487             if (gary)
2488                 Safefree(gary);
2489         }
2490 #else  /* HAS_SETGROUPS */
2491         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2492 #endif /* HAS_SETGROUPS */
2493         if (PL_delaymagic) {
2494             PL_delaymagic |= DM_EGID;
2495             break;                              /* don't do magic till later */
2496         }
2497 #ifdef HAS_SETEGID
2498         (void)setegid((Gid_t)PL_egid);
2499 #else
2500 #ifdef HAS_SETREGID
2501         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2502 #else
2503 #ifdef HAS_SETRESGID
2504         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2505 #else
2506         if (PL_egid == PL_gid)                  /* special case $) = $( */
2507             (void)PerlProc_setgid(PL_egid);
2508         else {
2509             PL_egid = PerlProc_getegid();
2510             Perl_croak(aTHX_ "setegid() not implemented");
2511         }
2512 #endif
2513 #endif
2514 #endif
2515         PL_egid = PerlProc_getegid();
2516         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2517         break;
2518     case ':':
2519         PL_chopset = SvPV_force(sv,len);
2520         break;
2521 #ifndef MACOS_TRADITIONAL
2522     case '0':
2523         LOCK_DOLLARZERO_MUTEX;
2524 #ifdef HAS_SETPROCTITLE
2525         /* The BSDs don't show the argv[] in ps(1) output, they
2526          * show a string from the process struct and provide
2527          * the setproctitle() routine to manipulate that. */
2528         if (PL_origalen != 1) {
2529             s = SvPV_const(sv, len);
2530 #   if __FreeBSD_version > 410001
2531             /* The leading "-" removes the "perl: " prefix,
2532              * but not the "(perl) suffix from the ps(1)
2533              * output, because that's what ps(1) shows if the
2534              * argv[] is modified. */
2535             setproctitle("-%s", s);
2536 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2537             /* This doesn't really work if you assume that
2538              * $0 = 'foobar'; will wipe out 'perl' from the $0
2539              * because in ps(1) output the result will be like
2540              * sprintf("perl: %s (perl)", s)
2541              * I guess this is a security feature:
2542              * one (a user process) cannot get rid of the original name.
2543              * --jhi */
2544             setproctitle("%s", s);
2545 #   endif
2546         }
2547 #endif
2548 #if defined(__hpux) && defined(PSTAT_SETCMD)
2549         if (PL_origalen != 1) {
2550              union pstun un;
2551              s = SvPV_const(sv, len);
2552              un.pst_command = (char *)s;
2553              pstat(PSTAT_SETCMD, un, len, 0, 0);
2554         }
2555 #endif
2556         if (PL_origalen > 1) {
2557             /* PL_origalen is set in perl_parse(). */
2558             s = SvPV_force(sv,len);
2559             if (len >= (STRLEN)PL_origalen-1) {
2560                 /* Longer than original, will be truncated. We assume that
2561                  * PL_origalen bytes are available. */
2562                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2563             }
2564             else {
2565                 /* Shorter than original, will be padded. */
2566                 Copy(s, PL_origargv[0], len, char);
2567                 PL_origargv[0][len] = 0;
2568                 memset(PL_origargv[0] + len + 1,
2569                        /* Is the space counterintuitive?  Yes.
2570                         * (You were expecting \0?)
2571                         * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2572                         * --jhi */
2573                        (int)' ',
2574                        PL_origalen - len - 1);
2575             }
2576             PL_origargv[0][PL_origalen-1] = 0;
2577             for (i = 1; i < PL_origargc; i++)
2578                 PL_origargv[i] = 0;
2579         }
2580         UNLOCK_DOLLARZERO_MUTEX;
2581         break;
2582 #endif
2583     }
2584     return 0;
2585 }
2586
2587 I32
2588 Perl_whichsig(pTHX_ const char *sig)
2589 {
2590     register char* const* sigv;
2591     PERL_UNUSED_CONTEXT;
2592
2593     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2594         if (strEQ(sig,*sigv))
2595             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2596 #ifdef SIGCLD
2597     if (strEQ(sig,"CHLD"))
2598         return SIGCLD;
2599 #endif
2600 #ifdef SIGCHLD
2601     if (strEQ(sig,"CLD"))
2602         return SIGCHLD;
2603 #endif
2604     return -1;
2605 }
2606
2607 Signal_t
2608 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2609 Perl_sighandler(int sig, ...)
2610 #else
2611 Perl_sighandler(int sig)
2612 #endif
2613 {
2614 #ifdef PERL_GET_SIG_CONTEXT
2615     dTHXa(PERL_GET_SIG_CONTEXT);
2616 #else
2617     dTHX;
2618 #endif
2619     dSP;
2620     GV *gv = NULL;
2621     SV *sv = NULL;
2622     SV * const tSv = PL_Sv;
2623     CV *cv = NULL;
2624     OP *myop = PL_op;
2625     U32 flags = 0;
2626     XPV * const tXpv = PL_Xpv;
2627
2628     if (PL_savestack_ix + 15 <= PL_savestack_max)
2629         flags |= 1;
2630     if (PL_markstack_ptr < PL_markstack_max - 2)
2631         flags |= 4;
2632     if (PL_scopestack_ix < PL_scopestack_max - 3)
2633         flags |= 16;
2634
2635     if (!PL_psig_ptr[sig]) {
2636                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2637                                  PL_sig_name[sig]);
2638                 exit(sig);
2639         }
2640
2641     /* Max number of items pushed there is 3*n or 4. We cannot fix
2642        infinity, so we fix 4 (in fact 5): */
2643     if (flags & 1) {
2644         PL_savestack_ix += 5;           /* Protect save in progress. */
2645         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2646     }
2647     if (flags & 4)
2648         PL_markstack_ptr++;             /* Protect mark. */
2649     if (flags & 16)
2650         PL_scopestack_ix += 1;
2651     /* sv_2cv is too complicated, try a simpler variant first: */
2652     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2653         || SvTYPE(cv) != SVt_PVCV) {
2654         HV *st;
2655         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2656     }
2657
2658     if (!cv || !CvROOT(cv)) {
2659         if (ckWARN(WARN_SIGNAL))
2660             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2661                 PL_sig_name[sig], (gv ? GvENAME(gv)
2662                                 : ((cv && CvGV(cv))
2663                                    ? GvENAME(CvGV(cv))
2664                                    : "__ANON__")));
2665         goto cleanup;
2666     }
2667
2668     if(PL_psig_name[sig]) {
2669         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2670         flags |= 64;
2671 #if !defined(PERL_IMPLICIT_CONTEXT)
2672         PL_sig_sv = sv;
2673 #endif
2674     } else {
2675         sv = sv_newmortal();
2676         sv_setpv(sv,PL_sig_name[sig]);
2677     }
2678
2679     PUSHSTACKi(PERLSI_SIGNAL);
2680     PUSHMARK(SP);
2681     PUSHs(sv);
2682 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2683     {
2684          struct sigaction oact;
2685
2686          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2687               siginfo_t *sip;
2688               va_list args;
2689
2690               va_start(args, sig);
2691               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2692               if (sip) {
2693                    HV *sih = newHV();
2694                    SV *rv  = newRV_noinc((SV*)sih);
2695                    /* The siginfo fields signo, code, errno, pid, uid,
2696                     * addr, status, and band are defined by POSIX/SUSv3. */
2697                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2698                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2699 #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. */
2700                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2701                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2702                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2703                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2704                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2705                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2706 #endif
2707                    EXTEND(SP, 2);
2708                    PUSHs((SV*)rv);
2709                    PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2710               }
2711
2712               va_end(args);
2713          }
2714     }
2715 #endif
2716     PUTBACK;
2717
2718     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2719
2720     POPSTACK;
2721     if (SvTRUE(ERRSV)) {
2722 #ifndef PERL_MICRO
2723 #ifdef HAS_SIGPROCMASK
2724         /* Handler "died", for example to get out of a restart-able read().
2725          * Before we re-do that on its behalf re-enable the signal which was
2726          * blocked by the system when we entered.
2727          */
2728         sigset_t set;
2729         sigemptyset(&set);
2730         sigaddset(&set,sig);
2731         sigprocmask(SIG_UNBLOCK, &set, NULL);
2732 #else
2733         /* Not clear if this will work */
2734         (void)rsignal(sig, SIG_IGN);
2735         (void)rsignal(sig, PL_csighandlerp);
2736 #endif
2737 #endif /* !PERL_MICRO */
2738         Perl_die(aTHX_ NULL);
2739     }
2740 cleanup:
2741     if (flags & 1)
2742         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2743     if (flags & 4)
2744         PL_markstack_ptr--;
2745     if (flags & 16)
2746         PL_scopestack_ix -= 1;
2747     if (flags & 64)
2748         SvREFCNT_dec(sv);
2749     PL_op = myop;                       /* Apparently not needed... */
2750
2751     PL_Sv = tSv;                        /* Restore global temporaries. */
2752     PL_Xpv = tXpv;
2753     return;
2754 }
2755
2756
2757 static void
2758 S_restore_magic(pTHX_ const void *p)
2759 {
2760     dVAR;
2761     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2762     SV* const sv = mgs->mgs_sv;
2763
2764     if (!sv)
2765         return;
2766
2767     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2768     {
2769 #ifdef PERL_OLD_COPY_ON_WRITE
2770         /* While magic was saved (and off) sv_setsv may well have seen
2771            this SV as a prime candidate for COW.  */
2772         if (SvIsCOW(sv))
2773             sv_force_normal_flags(sv, 0);
2774 #endif
2775
2776         if (mgs->mgs_flags)
2777             SvFLAGS(sv) |= mgs->mgs_flags;
2778         else
2779             mg_magical(sv);
2780         if (SvGMAGICAL(sv)) {
2781             /* downgrade public flags to private,
2782                and discard any other private flags */
2783
2784             U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2785             if (public) {
2786                 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2787                 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2788             }
2789         }
2790     }
2791
2792     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2793
2794     /* If we're still on top of the stack, pop us off.  (That condition
2795      * will be satisfied if restore_magic was called explicitly, but *not*
2796      * if it's being called via leave_scope.)
2797      * The reason for doing this is that otherwise, things like sv_2cv()
2798      * may leave alloc gunk on the savestack, and some code
2799      * (e.g. sighandler) doesn't expect that...
2800      */
2801     if (PL_savestack_ix == mgs->mgs_ss_ix)
2802     {
2803         I32 popval = SSPOPINT;
2804         assert(popval == SAVEt_DESTRUCTOR_X);
2805         PL_savestack_ix -= 2;
2806         popval = SSPOPINT;
2807         assert(popval == SAVEt_ALLOC);
2808         popval = SSPOPINT;
2809         PL_savestack_ix -= popval;
2810     }
2811
2812 }
2813
2814 static void
2815 S_unwind_handler_stack(pTHX_ const void *p)
2816 {
2817     dVAR;
2818     const U32 flags = *(const U32*)p;
2819
2820     if (flags & 1)
2821         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2822 #if !defined(PERL_IMPLICIT_CONTEXT)
2823     if (flags & 64)
2824         SvREFCNT_dec(PL_sig_sv);
2825 #endif
2826 }
2827
2828 /*
2829  * Local variables:
2830  * c-indentation-style: bsd
2831  * c-basic-offset: 4
2832  * indent-tabs-mode: t
2833  * End:
2834  *
2835  * ex: set ts=8 sts=4 sw=4 noet:
2836  */