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, $^UTF8CACHE */
 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         else if (strEQ(remaining, "TF8CACHE"))
 799             sv_setiv(sv, (IV) PL_utf8cache);
 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                 assert(rx->subbeg);
 851
 852               getrx:
 853                 if (i >= 0) {
 854                     const int oldtainted = PL_tainted;
 855                     TAINT_NOT;
 856                     sv_setpvn(sv, s, i);
 857                     PL_tainted = oldtainted;
 858                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 859                         SvUTF8_on(sv);
 860                     else
 861                         SvUTF8_off(sv);
 862                     if (PL_tainting) {
 863                         if (RX_MATCH_TAINTED(rx)) {
 864                             MAGIC* const mg = SvMAGIC(sv);
 865                             MAGIC* mgt;
 866                             PL_tainted = 1;
 867                             SvMAGIC_set(sv, mg->mg_moremagic);
 868                             SvTAINT(sv);
 869                             if ((mgt = SvMAGIC(sv))) {
 870                                 mg->mg_moremagic = mgt;
 871                                 SvMAGIC_set(sv, mg);
 872                             }
 873                         } else
 874                             SvTAINTED_off(sv);
 875                     }
 876                     break;
 877                 }
 878             }
 879         }
 880         sv_setsv(sv,&PL_sv_undef);
 881         break;
 882     case '+':
 883         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 884             paren = rx->lastparen;
 885             if (paren)
 886                 goto getparen;
 887         }
 888         sv_setsv(sv,&PL_sv_undef);
 889         break;
 890     case '\016':                /* ^N */
 891         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 892             paren = rx->lastcloseparen;
 893             if (paren)
 894                 goto getparen;
 895         }
 896         sv_setsv(sv,&PL_sv_undef);
 897         break;
 898     case '`':
 899         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 900             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 901                 i = rx->startp[0];
 902                 goto getrx;
 903             }
 904         }
 905         sv_setsv(sv,&PL_sv_undef);
 906         break;
 907     case '\'':
 908         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 909             if (rx->subbeg && rx->endp[0] != -1) {
 910                 s = rx->subbeg + rx->endp[0];
 911                 i = rx->sublen - rx->endp[0];
 912                 goto getrx;
 913             }
 914         }
 915         sv_setsv(sv,&PL_sv_undef);
 916         break;
 917     case '.':
 918         if (GvIO(PL_last_in_gv)) {
 919             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 920         }
 921         break;
 922     case '?':
 923         {
 924             sv_setiv(sv, (IV)STATUS_CURRENT);
 925 #ifdef COMPLEX_STATUS
 926             LvTARGOFF(sv) = PL_statusvalue;
 927             LvTARGLEN(sv) = PL_statusvalue_vms;
 928 #endif
 929         }
 930         break;
 931     case '^':
 932         if (GvIOp(PL_defoutgv))
 933             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 934         if (s)
 935             sv_setpv(sv,s);
 936         else {
 937             sv_setpv(sv,GvENAME(PL_defoutgv));
 938             sv_catpv(sv,"_TOP");
 939         }
 940         break;
 941     case '~':
 942         if (GvIOp(PL_defoutgv))
 943             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 944         if (!s)
 945             s = GvENAME(PL_defoutgv);
 946         sv_setpv(sv,s);
 947         break;
 948     case '=':
 949         if (GvIOp(PL_defoutgv))
 950             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 951         break;
 952     case '-':
 953         if (GvIOp(PL_defoutgv))
 954             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 955         break;
 956     case '%':
 957         if (GvIOp(PL_defoutgv))
 958             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 959         break;
 960     case ':':
 961         break;
 962     case '/':
 963         break;
 964     case '[':
 965         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 966         break;
 967     case '|':
 968         if (GvIOp(PL_defoutgv))
 969             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 970         break;
 971     case ',':
 972         break;
 973     case '\\':
 974         if (PL_ors_sv)
 975             sv_copypv(sv, PL_ors_sv);
 976         break;
 977     case '!':
 978 #ifdef VMS
 979         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 980         sv_setpv(sv, errno ? Strerror(errno) : "");
 981 #else
 982         {
 983         const int saveerrno = errno;
 984         sv_setnv(sv, (NV)errno);
 985 #ifdef OS2
 986         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 987             sv_setpv(sv, os2error(Perl_rc));
 988         else
 989 #endif
 990         sv_setpv(sv, errno ? Strerror(errno) : "");
 991         errno = saveerrno;
 992         }
 993 #endif
 994         SvRTRIM(sv);
 995         SvNOK_on(sv);   /* what a wonderful hack! */
 996         break;
 997     case '<':
 998         sv_setiv(sv, (IV)PL_uid);
 999         break;
1000     case '>':
1001         sv_setiv(sv, (IV)PL_euid);
1002         break;
1003     case '(':
1004         sv_setiv(sv, (IV)PL_gid);
1005         goto add_groups;
1006     case ')':
1007         sv_setiv(sv, (IV)PL_egid);
1008       add_groups:
1009 #ifdef HAS_GETGROUPS
1010         {
1011             Groups_t *gary = NULL;
1012             I32 i, num_groups = getgroups(0, gary);
1013             Newx(gary, num_groups, Groups_t);
1014             num_groups = getgroups(num_groups, gary);
1015             for (i = 0; i < num_groups; i++)
1016                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1017             Safefree(gary);
1018         }
1019         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1020 #endif
1021         break;
1022 #ifndef MACOS_TRADITIONAL
1023     case '0':
1024         break;
1025 #endif
1026     }
1027     return 0;
1028 }
1029
1030 int
1031 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1032 {
1033     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1034
1035     if (uf && uf->uf_val)
1036         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1037     return 0;
1038 }
1039
1040 int
1041 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1042 {
1043     dVAR;
1044     STRLEN len, klen;
1045     const char *s = SvPV_const(sv,len);
1046     const char * const ptr = MgPV_const(mg,klen);
1047     my_setenv(ptr, s);
1048
1049 #ifdef DYNAMIC_ENV_FETCH
1050      /* We just undefd an environment var.  Is a replacement */
1051      /* waiting in the wings? */
1052     if (!len) {
1053         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1054         if (valp)
1055             s = SvPV_const(*valp, len);
1056     }
1057 #endif
1058
1059 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1060                             /* And you'll never guess what the dog had */
1061                             /*   in its mouth... */
1062     if (PL_tainting) {
1063         MgTAINTEDDIR_off(mg);
1064 #ifdef VMS
1065         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1066             char pathbuf[256], eltbuf[256], *cp, *elt;
1067             Stat_t sbuf;
1068             int i = 0, j = 0;
1069
1070             strncpy(eltbuf, s, 255);
1071             eltbuf[255] = 0;
1072             elt = eltbuf;
1073             do {          /* DCL$PATH may be a search list */
1074                 while (1) {   /* as may dev portion of any element */
1075                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1076                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1077                              cando_by_name(S_IWUSR,0,elt) ) {
1078                             MgTAINTEDDIR_on(mg);
1079                             return 0;
1080                         }
1081                     }
1082                     if ((cp = strchr(elt, ':')) != NULL)
1083                         *cp = '\0';
1084                     if (my_trnlnm(elt, eltbuf, j++))
1085                         elt = eltbuf;
1086                     else
1087                         break;
1088                 }
1089                 j = 0;
1090             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1091         }
1092 #endif /* VMS */
1093         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1094             const char * const strend = s + len;
1095
1096             while (s < strend) {
1097                 char tmpbuf[256];
1098                 Stat_t st;
1099                 I32 i;
1100                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1101                              s, strend, ':', &i);
1102                 s++;
1103                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1104                       || *tmpbuf != '/'
1105                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1106                     MgTAINTEDDIR_on(mg);
1107                     return 0;
1108                 }
1109             }
1110         }
1111     }
1112 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1113
1114     return 0;
1115 }
1116
1117 int
1118 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1119 {
1120     PERL_UNUSED_ARG(sv);
1121     my_setenv(MgPV_nolen_const(mg),NULL);
1122     return 0;
1123 }
1124
1125 int
1126 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1127 {
1128     dVAR;
1129     PERL_UNUSED_ARG(mg);
1130 #if defined(VMS)
1131     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1132 #else
1133     if (PL_localizing) {
1134         HE* entry;
1135         my_clearenv();
1136         hv_iterinit((HV*)sv);
1137         while ((entry = hv_iternext((HV*)sv))) {
1138             I32 keylen;
1139             my_setenv(hv_iterkey(entry, &keylen),
1140                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1141         }
1142     }
1143 #endif
1144     return 0;
1145 }
1146
1147 int
1148 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1149 {
1150     dVAR;
1151     PERL_UNUSED_ARG(sv);
1152     PERL_UNUSED_ARG(mg);
1153 #if defined(VMS)
1154     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1155 #else
1156     my_clearenv();
1157 #endif
1158     return 0;
1159 }
1160
1161 #ifndef PERL_MICRO
1162 #ifdef HAS_SIGPROCMASK
1163 static void
1164 restore_sigmask(pTHX_ SV *save_sv)
1165 {
1166     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1167     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1168 }
1169 #endif
1170 int
1171 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1172 {
1173     dVAR;
1174     /* Are we fetching a signal entry? */
1175     const I32 i = whichsig(MgPV_nolen_const(mg));
1176     if (i > 0) {
1177         if(PL_psig_ptr[i])
1178             sv_setsv(sv,PL_psig_ptr[i]);
1179         else {
1180             Sighandler_t sigstate;
1181             sigstate = rsignal_state(i);
1182 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1183             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1184 #endif
1185 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1186             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1187 #endif
1188             /* cache state so we don't fetch it again */
1189             if(sigstate == (Sighandler_t) SIG_IGN)
1190                 sv_setpv(sv,"IGNORE");
1191             else
1192                 sv_setsv(sv,&PL_sv_undef);
1193             PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1194             SvTEMP_off(sv);
1195         }
1196     }
1197     return 0;
1198 }
1199 int
1200 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1201 {
1202     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1203      * refactoring might be in order.
1204      */
1205     dVAR;
1206     register const char * const s = MgPV_nolen_const(mg);
1207     PERL_UNUSED_ARG(sv);
1208     if (*s == '_') {
1209         SV** svp = NULL;
1210         if (strEQ(s,"__DIE__"))
1211             svp = &PL_diehook;
1212         else if (strEQ(s,"__WARN__"))
1213             svp = &PL_warnhook;
1214         else
1215             Perl_croak(aTHX_ "No such hook: %s", s);
1216         if (svp && *svp) {
1217             SV * const to_dec = *svp;
1218             *svp = NULL;
1219             SvREFCNT_dec(to_dec);
1220         }
1221     }
1222     else {
1223         /* Are we clearing a signal entry? */
1224         const I32 i = whichsig(s);
1225         if (i > 0) {
1226 #ifdef HAS_SIGPROCMASK
1227             sigset_t set, save;
1228             SV* save_sv;
1229             /* Avoid having the signal arrive at a bad time, if possible. */
1230             sigemptyset(&set);
1231             sigaddset(&set,i);
1232             sigprocmask(SIG_BLOCK, &set, &save);
1233             ENTER;
1234             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1235             SAVEFREESV(save_sv);
1236             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1237 #endif
1238             PERL_ASYNC_CHECK();
1239 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1240             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1241 #endif
1242 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1243             PL_sig_defaulting[i] = 1;
1244             (void)rsignal(i, PL_csighandlerp);
1245 #else
1246             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1247 #endif
1248             if(PL_psig_name[i]) {
1249                 SvREFCNT_dec(PL_psig_name[i]);
1250                 PL_psig_name[i]=0;
1251             }
1252             if(PL_psig_ptr[i]) {
1253                 SV * const to_dec=PL_psig_ptr[i];
1254                 PL_psig_ptr[i]=0;
1255                 LEAVE;
1256                 SvREFCNT_dec(to_dec);
1257             }
1258             else
1259                 LEAVE;
1260         }
1261     }
1262     return 0;
1263 }
1264
1265 static void
1266 S_raise_signal(pTHX_ int sig)
1267 {
1268     dVAR;
1269     /* Set a flag to say this signal is pending */
1270     PL_psig_pend[sig]++;
1271     /* And one to say _a_ signal is pending */
1272     PL_sig_pending = 1;
1273 }
1274
1275 Signal_t
1276 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1277 Perl_csighandler(int sig, ...)
1278 #else
1279 Perl_csighandler(int sig)
1280 #endif
1281 {
1282 #ifdef PERL_GET_SIG_CONTEXT
1283     dTHXa(PERL_GET_SIG_CONTEXT);
1284 #else
1285     dTHX;
1286 #endif
1287 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1288     (void) rsignal(sig, PL_csighandlerp);
1289     if (PL_sig_ignoring[sig]) return;
1290 #endif
1291 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1292     if (PL_sig_defaulting[sig])
1293 #ifdef KILL_BY_SIGPRC
1294             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1295 #else
1296             exit(1);
1297 #endif
1298 #endif
1299    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1300         /* Call the perl level handler now--
1301          * with risk we may be in malloc() etc. */
1302         (*PL_sighandlerp)(sig);
1303    else
1304         S_raise_signal(aTHX_ sig);
1305 }
1306
1307 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1308 void
1309 Perl_csighandler_init(void)
1310 {
1311     int sig;
1312     if (PL_sig_handlers_initted) return;
1313
1314     for (sig = 1; sig < SIG_SIZE; sig++) {
1315 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1316         dTHX;
1317         PL_sig_defaulting[sig] = 1;
1318         (void) rsignal(sig, PL_csighandlerp);
1319 #endif
1320 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1321         PL_sig_ignoring[sig] = 0;
1322 #endif
1323     }
1324     PL_sig_handlers_initted = 1;
1325 }
1326 #endif
1327
1328 void
1329 Perl_despatch_signals(pTHX)
1330 {
1331     dVAR;
1332     int sig;
1333     PL_sig_pending = 0;
1334     for (sig = 1; sig < SIG_SIZE; sig++) {
1335         if (PL_psig_pend[sig]) {
1336             PERL_BLOCKSIG_ADD(set, sig);
1337             PL_psig_pend[sig] = 0;
1338             PERL_BLOCKSIG_BLOCK(set);
1339             (*PL_sighandlerp)(sig);
1340             PERL_BLOCKSIG_UNBLOCK(set);
1341         }
1342     }
1343 }
1344
1345 int
1346 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1347 {
1348     dVAR;
1349     I32 i;
1350     SV** svp = NULL;
1351     /* Need to be careful with SvREFCNT_dec(), because that can have side
1352      * effects (due to closures). We must make sure that the new disposition
1353      * is in place before it is called.
1354      */
1355     SV* to_dec = NULL;
1356     STRLEN len;
1357 #ifdef HAS_SIGPROCMASK
1358     sigset_t set, save;
1359     SV* save_sv;
1360 #endif
1361
1362     register const char *s = MgPV_const(mg,len);
1363     if (*s == '_') {
1364         if (strEQ(s,"__DIE__"))
1365             svp = &PL_diehook;
1366         else if (strEQ(s,"__WARN__"))
1367             svp = &PL_warnhook;
1368         else
1369             Perl_croak(aTHX_ "No such hook: %s", s);
1370         i = 0;
1371         if (*svp) {
1372             to_dec = *svp;
1373             *svp = NULL;
1374         }
1375     }
1376     else {
1377         i = whichsig(s);        /* ...no, a brick */
1378         if (i <= 0) {
1379             if (ckWARN(WARN_SIGNAL))
1380                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1381             return 0;
1382         }
1383 #ifdef HAS_SIGPROCMASK
1384         /* Avoid having the signal arrive at a bad time, if possible. */
1385         sigemptyset(&set);
1386         sigaddset(&set,i);
1387         sigprocmask(SIG_BLOCK, &set, &save);
1388         ENTER;
1389         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1390         SAVEFREESV(save_sv);
1391         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1392 #endif
1393         PERL_ASYNC_CHECK();
1394 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1395         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1396 #endif
1397 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1398         PL_sig_ignoring[i] = 0;
1399 #endif
1400 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1401         PL_sig_defaulting[i] = 0;
1402 #endif
1403         SvREFCNT_dec(PL_psig_name[i]);
1404         to_dec = PL_psig_ptr[i];
1405         PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
1406         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1407         PL_psig_name[i] = newSVpvn(s, len);
1408         SvREADONLY_on(PL_psig_name[i]);
1409     }
1410     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1411         if (i) {
1412             (void)rsignal(i, PL_csighandlerp);
1413 #ifdef HAS_SIGPROCMASK
1414             LEAVE;
1415 #endif
1416         }
1417         else
1418             *svp = SvREFCNT_inc_simple_NN(sv);
1419         if(to_dec)
1420             SvREFCNT_dec(to_dec);
1421         return 0;
1422     }
1423     s = SvPV_force(sv,len);
1424     if (strEQ(s,"IGNORE")) {
1425         if (i) {
1426 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1427             PL_sig_ignoring[i] = 1;
1428             (void)rsignal(i, PL_csighandlerp);
1429 #else
1430             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1431 #endif
1432         }
1433     }
1434     else if (strEQ(s,"DEFAULT") || !*s) {
1435         if (i)
1436 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1437           {
1438             PL_sig_defaulting[i] = 1;
1439             (void)rsignal(i, PL_csighandlerp);
1440           }
1441 #else
1442             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1443 #endif
1444     }
1445     else {
1446         /*
1447          * We should warn if HINT_STRICT_REFS, but without
1448          * access to a known hint bit in a known OP, we can't
1449          * tell whether HINT_STRICT_REFS is in force or not.
1450          */
1451         if (!strchr(s,':') && !strchr(s,'\''))
1452             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1453         if (i)
1454             (void)rsignal(i, PL_csighandlerp);
1455         else
1456             *svp = SvREFCNT_inc_simple(sv);
1457     }
1458 #ifdef HAS_SIGPROCMASK
1459     if(i)
1460         LEAVE;
1461 #endif
1462     if(to_dec)
1463         SvREFCNT_dec(to_dec);
1464     return 0;
1465 }
1466 #endif /* !PERL_MICRO */
1467
1468 int
1469 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1470 {
1471     dVAR;
1472     PERL_UNUSED_ARG(sv);
1473     PERL_UNUSED_ARG(mg);
1474     PL_sub_generation++;
1475     return 0;
1476 }
1477
1478 int
1479 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1480 {
1481     dVAR;
1482     PERL_UNUSED_ARG(sv);
1483     PERL_UNUSED_ARG(mg);
1484     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1485     PL_amagic_generation++;
1486
1487     return 0;
1488 }
1489
1490 int
1491 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1492 {
1493     HV * const hv = (HV*)LvTARG(sv);
1494     I32 i = 0;
1495     PERL_UNUSED_ARG(mg);
1496
1497     if (hv) {
1498          (void) hv_iterinit(hv);
1499          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1500              i = HvKEYS(hv);
1501          else {
1502              while (hv_iternext(hv))
1503                  i++;
1504          }
1505     }
1506
1507     sv_setiv(sv, (IV)i);
1508     return 0;
1509 }
1510
1511 int
1512 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1513 {
1514     PERL_UNUSED_ARG(mg);
1515     if (LvTARG(sv)) {
1516         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1517     }
1518     return 0;
1519 }
1520
1521 /* caller is responsible for stack switching/cleanup */
1522 STATIC int
1523 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1524 {
1525     dVAR;
1526     dSP;
1527
1528     PUSHMARK(SP);
1529     EXTEND(SP, n);
1530     PUSHs(SvTIED_obj(sv, mg));
1531     if (n > 1) {
1532         if (mg->mg_ptr) {
1533             if (mg->mg_len >= 0)
1534                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1535             else if (mg->mg_len == HEf_SVKEY)
1536                 PUSHs((SV*)mg->mg_ptr);
1537         }
1538         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1539             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1540         }
1541     }
1542     if (n > 2) {
1543         PUSHs(val);
1544     }
1545     PUTBACK;
1546
1547     return call_method(meth, flags);
1548 }
1549
1550 STATIC int
1551 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1552 {
1553     dVAR; dSP;
1554
1555     ENTER;
1556     SAVETMPS;
1557     PUSHSTACKi(PERLSI_MAGIC);
1558
1559     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1560         sv_setsv(sv, *PL_stack_sp--);
1561     }
1562
1563     POPSTACK;
1564     FREETMPS;
1565     LEAVE;
1566     return 0;
1567 }
1568
1569 int
1570 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1571 {
1572     if (mg->mg_ptr)
1573         mg->mg_flags |= MGf_GSKIP;
1574     magic_methpack(sv,mg,"FETCH");
1575     return 0;
1576 }
1577
1578 int
1579 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1580 {
1581     dVAR; dSP;
1582     ENTER;
1583     PUSHSTACKi(PERLSI_MAGIC);
1584     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1585     POPSTACK;
1586     LEAVE;
1587     return 0;
1588 }
1589
1590 int
1591 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1592 {
1593     return magic_methpack(sv,mg,"DELETE");
1594 }
1595
1596
1597 U32
1598 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1599 {
1600     dVAR; dSP;
1601     U32 retval = 0;
1602
1603     ENTER;
1604     SAVETMPS;
1605     PUSHSTACKi(PERLSI_MAGIC);
1606     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1607         sv = *PL_stack_sp--;
1608         retval = (U32) SvIV(sv)-1;
1609     }
1610     POPSTACK;
1611     FREETMPS;
1612     LEAVE;
1613     return retval;
1614 }
1615
1616 int
1617 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1618 {
1619     dVAR; dSP;
1620
1621     ENTER;
1622     PUSHSTACKi(PERLSI_MAGIC);
1623     PUSHMARK(SP);
1624     XPUSHs(SvTIED_obj(sv, mg));
1625     PUTBACK;
1626     call_method("CLEAR", G_SCALAR|G_DISCARD);
1627     POPSTACK;
1628     LEAVE;
1629
1630     return 0;
1631 }
1632
1633 int
1634 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1635 {
1636     dVAR; dSP;
1637     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1638
1639     ENTER;
1640     SAVETMPS;
1641     PUSHSTACKi(PERLSI_MAGIC);
1642     PUSHMARK(SP);
1643     EXTEND(SP, 2);
1644     PUSHs(SvTIED_obj(sv, mg));
1645     if (SvOK(key))
1646         PUSHs(key);
1647     PUTBACK;
1648
1649     if (call_method(meth, G_SCALAR))
1650         sv_setsv(key, *PL_stack_sp--);
1651
1652     POPSTACK;
1653     FREETMPS;
1654     LEAVE;
1655     return 0;
1656 }
1657
1658 int
1659 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1660 {
1661     return magic_methpack(sv,mg,"EXISTS");
1662 }
1663
1664 SV *
1665 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1666 {
1667     dVAR; dSP;
1668     SV *retval = &PL_sv_undef;
1669     SV * const tied = SvTIED_obj((SV*)hv, mg);
1670     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1671
1672     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1673         SV *key;
1674         if (HvEITER_get(hv))
1675             /* we are in an iteration so the hash cannot be empty */
1676             return &PL_sv_yes;
1677         /* no xhv_eiter so now use FIRSTKEY */
1678         key = sv_newmortal();
1679         magic_nextpack((SV*)hv, mg, key);
1680         HvEITER_set(hv, NULL);     /* need to reset iterator */
1681         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1682     }
1683
1684     /* there is a SCALAR method that we can call */
1685     ENTER;
1686     PUSHSTACKi(PERLSI_MAGIC);
1687     PUSHMARK(SP);
1688     EXTEND(SP, 1);
1689     PUSHs(tied);
1690     PUTBACK;
1691
1692     if (call_method("SCALAR", G_SCALAR))
1693         retval = *PL_stack_sp--;
1694     POPSTACK;
1695     LEAVE;
1696     return retval;
1697 }
1698
1699 int
1700 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1701 {
1702     dVAR;
1703     GV * const gv = PL_DBline;
1704     const I32 i = SvTRUE(sv);
1705     SV ** const svp = av_fetch(GvAV(gv),
1706                      atoi(MgPV_nolen_const(mg)), FALSE);
1707     if (svp && SvIOKp(*svp)) {
1708         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1709         if (o) {
1710             /* set or clear breakpoint in the relevant control op */
1711             if (i)
1712                 o->op_flags |= OPf_SPECIAL;
1713             else
1714                 o->op_flags &= ~OPf_SPECIAL;
1715         }
1716     }
1717     return 0;
1718 }
1719
1720 int
1721 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1722 {
1723     dVAR;
1724     const AV * const obj = (AV*)mg->mg_obj;
1725     if (obj) {
1726         sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1727     } else {
1728         SvOK_off(sv);
1729     }
1730     return 0;
1731 }
1732
1733 int
1734 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1735 {
1736     dVAR;
1737     AV * const obj = (AV*)mg->mg_obj;
1738     if (obj) {
1739         av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1740     } else {
1741         if (ckWARN(WARN_MISC))
1742             Perl_warner(aTHX_ packWARN(WARN_MISC),
1743                         "Attempt to set length of freed array");
1744     }
1745     return 0;
1746 }
1747
1748 int
1749 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1750 {
1751     dVAR;
1752     PERL_UNUSED_ARG(sv);
1753     /* during global destruction, mg_obj may already have been freed */
1754     if (PL_in_clean_all)
1755         return 0;
1756
1757     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1758
1759     if (mg) {
1760         /* arylen scalar holds a pointer back to the array, but doesn't own a
1761            reference. Hence the we (the array) are about to go away with it
1762            still pointing at us. Clear its pointer, else it would be pointing
1763            at free memory. See the comment in sv_magic about reference loops,
1764            and why it can't own a reference to us.  */
1765         mg->mg_obj = 0;
1766     }
1767     return 0;
1768 }
1769
1770 int
1771 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1772 {
1773     dVAR;
1774     SV* const lsv = LvTARG(sv);
1775
1776     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1777         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1778         if (mg && mg->mg_len >= 0) {
1779             I32 i = mg->mg_len;
1780             if (DO_UTF8(lsv))
1781                 sv_pos_b2u(lsv, &i);
1782             sv_setiv(sv, i + PL_curcop->cop_arybase);
1783             return 0;
1784         }
1785     }
1786     SvOK_off(sv);
1787     return 0;
1788 }
1789
1790 int
1791 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1792 {
1793     dVAR;
1794     SV* const lsv = LvTARG(sv);
1795     SSize_t pos;
1796     STRLEN len;
1797     STRLEN ulen = 0;
1798
1799     mg = 0;
1800
1801     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1802         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1803     if (!mg) {
1804         if (!SvOK(sv))
1805             return 0;
1806         sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1807         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1808     }
1809     else if (!SvOK(sv)) {
1810         mg->mg_len = -1;
1811         return 0;
1812     }
1813     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1814
1815     pos = SvIV(sv) - PL_curcop->cop_arybase;
1816
1817     if (DO_UTF8(lsv)) {
1818         ulen = sv_len_utf8(lsv);
1819         if (ulen)
1820             len = ulen;
1821     }
1822
1823     if (pos < 0) {
1824         pos += len;
1825         if (pos < 0)
1826             pos = 0;
1827     }
1828     else if (pos > (SSize_t)len)
1829         pos = len;
1830
1831     if (ulen) {
1832         I32 p = pos;
1833         sv_pos_u2b(lsv, &p, 0);
1834         pos = p;
1835     }
1836
1837     mg->mg_len = pos;
1838     mg->mg_flags &= ~MGf_MINMATCH;
1839
1840     return 0;
1841 }
1842
1843 int
1844 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1845 {
1846     GV* gv;
1847     PERL_UNUSED_ARG(mg);
1848
1849     if (!SvOK(sv))
1850         return 0;
1851     if (SvFLAGS(sv) & SVp_SCREAM
1852         && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1853         /* We're actually already a typeglob, so don't need the stuff below.
1854          */
1855         return 0;
1856     }
1857     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1858     if (sv == (SV*)gv)
1859         return 0;
1860     if (GvGP(sv))
1861         gp_free((GV*)sv);
1862     GvGP(sv) = gp_ref(GvGP(gv));
1863     return 0;
1864 }
1865
1866 int
1867 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1868 {
1869     STRLEN len;
1870     SV * const lsv = LvTARG(sv);
1871     const char * const tmps = SvPV_const(lsv,len);
1872     I32 offs = LvTARGOFF(sv);
1873     I32 rem = LvTARGLEN(sv);
1874     PERL_UNUSED_ARG(mg);
1875
1876     if (SvUTF8(lsv))
1877         sv_pos_u2b(lsv, &offs, &rem);
1878     if (offs > (I32)len)
1879         offs = len;
1880     if (rem + offs > (I32)len)
1881         rem = len - offs;
1882     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1883     if (SvUTF8(lsv))
1884         SvUTF8_on(sv);
1885     return 0;
1886 }
1887
1888 int
1889 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1890 {
1891     dVAR;
1892     STRLEN len;
1893     const char *tmps = SvPV_const(sv, len);
1894     SV * const lsv = LvTARG(sv);
1895     I32 lvoff = LvTARGOFF(sv);
1896     I32 lvlen = LvTARGLEN(sv);
1897     PERL_UNUSED_ARG(mg);
1898
1899     if (DO_UTF8(sv)) {
1900         sv_utf8_upgrade(lsv);
1901         sv_pos_u2b(lsv, &lvoff, &lvlen);
1902         sv_insert(lsv, lvoff, lvlen, tmps, len);
1903         LvTARGLEN(sv) = sv_len_utf8(sv);
1904         SvUTF8_on(lsv);
1905     }
1906     else if (lsv && SvUTF8(lsv)) {
1907         sv_pos_u2b(lsv, &lvoff, &lvlen);
1908         LvTARGLEN(sv) = len;
1909         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1910         sv_insert(lsv, lvoff, lvlen, tmps, len);
1911         Safefree(tmps);
1912     }
1913     else {
1914         sv_insert(lsv, lvoff, lvlen, tmps, len);
1915         LvTARGLEN(sv) = len;
1916     }
1917
1918
1919     return 0;
1920 }
1921
1922 int
1923 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1924 {
1925     dVAR;
1926     PERL_UNUSED_ARG(sv);
1927     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1928     return 0;
1929 }
1930
1931 int
1932 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1933 {
1934     dVAR;
1935     PERL_UNUSED_ARG(sv);
1936     /* update taint status unless we're restoring at scope exit */
1937     if (PL_localizing != 2) {
1938         if (PL_tainted)
1939             mg->mg_len |= 1;
1940         else
1941             mg->mg_len &= ~1;
1942     }
1943     return 0;
1944 }
1945
1946 int
1947 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1948 {
1949     SV * const lsv = LvTARG(sv);
1950     PERL_UNUSED_ARG(mg);
1951
1952     if (lsv)
1953         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1954     else
1955         SvOK_off(sv);
1956
1957     return 0;
1958 }
1959
1960 int
1961 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1962 {
1963     PERL_UNUSED_ARG(mg);
1964     do_vecset(sv);      /* XXX slurp this routine */
1965     return 0;
1966 }
1967
1968 int
1969 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1970 {
1971     dVAR;
1972     SV *targ = NULL;
1973     if (LvTARGLEN(sv)) {
1974         if (mg->mg_obj) {
1975             SV * const ahv = LvTARG(sv);
1976             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1977             if (he)
1978                 targ = HeVAL(he);
1979         }
1980         else {
1981             AV* const av = (AV*)LvTARG(sv);
1982             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1983                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1984         }
1985         if (targ && targ != &PL_sv_undef) {
1986             /* somebody else defined it for us */
1987             SvREFCNT_dec(LvTARG(sv));
1988             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
1989             LvTARGLEN(sv) = 0;
1990             SvREFCNT_dec(mg->mg_obj);
1991             mg->mg_obj = NULL;
1992             mg->mg_flags &= ~MGf_REFCOUNTED;
1993         }
1994     }
1995     else
1996         targ = LvTARG(sv);
1997     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1998     return 0;
1999 }
2000
2001 int
2002 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2003 {
2004     PERL_UNUSED_ARG(mg);
2005     if (LvTARGLEN(sv))
2006         vivify_defelem(sv);
2007     if (LvTARG(sv)) {
2008         sv_setsv(LvTARG(sv), sv);
2009         SvSETMAGIC(LvTARG(sv));
2010     }
2011     return 0;
2012 }
2013
2014 void
2015 Perl_vivify_defelem(pTHX_ SV *sv)
2016 {
2017     dVAR;
2018     MAGIC *mg;
2019     SV *value = NULL;
2020
2021     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2022         return;
2023     if (mg->mg_obj) {
2024         SV * const ahv = LvTARG(sv);
2025         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2026         if (he)
2027             value = HeVAL(he);
2028         if (!value || value == &PL_sv_undef)
2029             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2030     }
2031     else {
2032         AV* const av = (AV*)LvTARG(sv);
2033         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2034             LvTARG(sv) = NULL;  /* array can't be extended */
2035         else {
2036             SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2037             if (!svp || (value = *svp) == &PL_sv_undef)
2038                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2039         }
2040     }
2041     SvREFCNT_inc_simple_void(value);
2042     SvREFCNT_dec(LvTARG(sv));
2043     LvTARG(sv) = value;
2044     LvTARGLEN(sv) = 0;
2045     SvREFCNT_dec(mg->mg_obj);
2046     mg->mg_obj = NULL;
2047     mg->mg_flags &= ~MGf_REFCOUNTED;
2048 }
2049
2050 int
2051 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2052 {
2053     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2054 }
2055
2056 int
2057 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2058 {
2059     PERL_UNUSED_CONTEXT;
2060     mg->mg_len = -1;
2061     SvSCREAM_off(sv);
2062     return 0;
2063 }
2064
2065 int
2066 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2067 {
2068     PERL_UNUSED_ARG(mg);
2069     sv_unmagic(sv, PERL_MAGIC_bm);
2070     SvVALID_off(sv);
2071     return 0;
2072 }
2073
2074 int
2075 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2076 {
2077     PERL_UNUSED_ARG(mg);
2078     sv_unmagic(sv, PERL_MAGIC_fm);
2079     SvCOMPILED_off(sv);
2080     return 0;
2081 }
2082
2083 int
2084 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2085 {
2086     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2087
2088     if (uf && uf->uf_set)
2089         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2090     return 0;
2091 }
2092
2093 int
2094 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2095 {
2096     PERL_UNUSED_ARG(mg);
2097     sv_unmagic(sv, PERL_MAGIC_qr);
2098     return 0;
2099 }
2100
2101 int
2102 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2103 {
2104     dVAR;
2105     regexp * const re = (regexp *)mg->mg_obj;
2106     PERL_UNUSED_ARG(sv);
2107
2108     ReREFCNT_dec(re);
2109     return 0;
2110 }
2111
2112 #ifdef USE_LOCALE_COLLATE
2113 int
2114 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2115 {
2116     /*
2117      * RenE<eacute> Descartes said "I think not."
2118      * and vanished with a faint plop.
2119      */
2120     PERL_UNUSED_CONTEXT;
2121     PERL_UNUSED_ARG(sv);
2122     if (mg->mg_ptr) {
2123         Safefree(mg->mg_ptr);
2124         mg->mg_ptr = NULL;
2125         mg->mg_len = -1;
2126     }
2127     return 0;
2128 }
2129 #endif /* USE_LOCALE_COLLATE */
2130
2131 /* Just clear the UTF-8 cache data. */
2132 int
2133 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2134 {
2135     PERL_UNUSED_CONTEXT;
2136     PERL_UNUSED_ARG(sv);
2137     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2138     mg->mg_ptr = 0;
2139     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2140     return 0;
2141 }
2142
2143 int
2144 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2145 {
2146     dVAR;
2147     register const char *s;
2148     I32 i;
2149     STRLEN len;
2150     switch (*mg->mg_ptr) {
2151     case '\001':        /* ^A */
2152         sv_setsv(PL_bodytarget, sv);
2153         break;
2154     case '\003':        /* ^C */
2155         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2156         break;
2157
2158     case '\004':        /* ^D */
2159 #ifdef DEBUGGING
2160         s = SvPV_nolen_const(sv);
2161         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2162         DEBUG_x(dump_all());
2163 #else
2164         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2165 #endif
2166         break;
2167     case '\005':  /* ^E */
2168         if (*(mg->mg_ptr+1) == '\0') {
2169 #ifdef MACOS_TRADITIONAL
2170             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2171 #else
2172 #  ifdef VMS
2173             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2174 #  else
2175 #    ifdef WIN32
2176             SetLastError( SvIV(sv) );
2177 #    else
2178 #      ifdef OS2
2179             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2180 #      else
2181             /* will anyone ever use this? */
2182             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2183 #      endif
2184 #    endif
2185 #  endif
2186 #endif
2187         }
2188         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2189             if (PL_encoding)
2190                 SvREFCNT_dec(PL_encoding);
2191             if (SvOK(sv) || SvGMAGICAL(sv)) {
2192                 PL_encoding = newSVsv(sv);
2193             }
2194             else {
2195                 PL_encoding = NULL;
2196             }
2197         }
2198         break;
2199     case '\006':        /* ^F */
2200         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2201         break;
2202     case '\010':        /* ^H */
2203         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2204         break;
2205     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2206         Safefree(PL_inplace);
2207         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2208         break;
2209     case '\017':        /* ^O */
2210         if (*(mg->mg_ptr+1) == '\0') {
2211             Safefree(PL_osname);
2212             PL_osname = NULL;
2213             if (SvOK(sv)) {
2214                 TAINT_PROPER("assigning to $^O");
2215                 PL_osname = savesvpv(sv);
2216             }
2217         }
2218         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2219             if (!PL_compiling.cop_io)
2220                 PL_compiling.cop_io = newSVsv(sv);
2221             else
2222                 sv_setsv(PL_compiling.cop_io,sv);
2223         }
2224         break;
2225     case '\020':        /* ^P */
2226         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2227         if (PL_perldb && !PL_DBsingle)
2228             init_debugger();
2229         break;
2230     case '\024':        /* ^T */
2231 #ifdef BIG_TIME
2232         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2233 #else
2234         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2235 #endif
2236         break;
2237     case '\025':        /* ^UTF8CACHE */
2238          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2239              PL_utf8cache = (signed char) sv_2iv(sv);
2240          }
2241          break;
2242     case '\027':        /* ^W & $^WARNING_BITS */
2243         if (*(mg->mg_ptr+1) == '\0') {
2244             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2245                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2246                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2247                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2248             }
2249         }
2250         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2251             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2252                 if (!SvPOK(sv) && PL_localizing) {
2253                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2254                     PL_compiling.cop_warnings = pWARN_NONE;
2255                     break;
2256                 }
2257                 {
2258                     STRLEN len, i;
2259                     int accumulate = 0 ;
2260                     int any_fatals = 0 ;
2261                     const char * const ptr = SvPV_const(sv, len) ;
2262                     for (i = 0 ; i < len ; ++i) {
2263                         accumulate |= ptr[i] ;
2264                         any_fatals |= (ptr[i] & 0xAA) ;
2265                     }
2266                     if (!accumulate)
2267                         PL_compiling.cop_warnings = pWARN_NONE;
2268                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2269                         PL_compiling.cop_warnings = pWARN_ALL;
2270                         PL_dowarn |= G_WARN_ONCE ;
2271                     }
2272                     else {
2273                         if (specialWARN(PL_compiling.cop_warnings))
2274                             PL_compiling.cop_warnings = newSVsv(sv) ;
2275                         else
2276                             sv_setsv(PL_compiling.cop_warnings, sv);
2277                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2278                             PL_dowarn |= G_WARN_ONCE ;
2279                     }
2280
2281                 }
2282             }
2283         }
2284         break;
2285     case '.':
2286         if (PL_localizing) {
2287             if (PL_localizing == 1)
2288                 SAVESPTR(PL_last_in_gv);
2289         }
2290         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2291             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2292         break;
2293     case '^':
2294         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2295         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2296         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2297         break;
2298     case '~':
2299         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2300         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2301         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2302         break;
2303     case '=':
2304         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2305         break;
2306     case '-':
2307         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2308         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2309             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2310         break;
2311     case '%':
2312         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2313         break;
2314     case '|':
2315         {
2316             IO * const io = GvIOp(PL_defoutgv);
2317             if(!io)
2318               break;
2319             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2320                 IoFLAGS(io) &= ~IOf_FLUSH;
2321             else {
2322                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2323                     PerlIO *ofp = IoOFP(io);
2324                     if (ofp)
2325                         (void)PerlIO_flush(ofp);
2326                     IoFLAGS(io) |= IOf_FLUSH;
2327                 }
2328             }
2329         }
2330         break;
2331     case '/':
2332         SvREFCNT_dec(PL_rs);
2333         PL_rs = newSVsv(sv);
2334         break;
2335     case '\\':
2336         if (PL_ors_sv)
2337             SvREFCNT_dec(PL_ors_sv);
2338         if (SvOK(sv) || SvGMAGICAL(sv)) {
2339             PL_ors_sv = newSVsv(sv);
2340         }
2341         else {
2342             PL_ors_sv = NULL;
2343         }
2344         break;
2345     case ',':
2346         if (PL_ofs_sv)
2347             SvREFCNT_dec(PL_ofs_sv);
2348         if (SvOK(sv) || SvGMAGICAL(sv)) {
2349             PL_ofs_sv = newSVsv(sv);
2350         }
2351         else {
2352             PL_ofs_sv = NULL;
2353         }
2354         break;
2355     case '[':
2356         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2357         break;
2358     case '?':
2359 #ifdef COMPLEX_STATUS
2360         if (PL_localizing == 2) {
2361             PL_statusvalue = LvTARGOFF(sv);
2362             PL_statusvalue_vms = LvTARGLEN(sv);
2363         }
2364         else
2365 #endif
2366 #ifdef VMSISH_STATUS
2367         if (VMSISH_STATUS)
2368             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2369         else
2370 #endif
2371             STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2372         break;
2373     case '!':
2374         {
2375 #ifdef VMS
2376 #   define PERL_VMS_BANG vaxc$errno
2377 #else
2378 #   define PERL_VMS_BANG 0
2379 #endif
2380         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2381                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2382         }
2383         break;
2384     case '<':
2385         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2386         if (PL_delaymagic) {
2387             PL_delaymagic |= DM_RUID;
2388             break;                              /* don't do magic till later */
2389         }
2390 #ifdef HAS_SETRUID
2391         (void)setruid((Uid_t)PL_uid);
2392 #else
2393 #ifdef HAS_SETREUID
2394         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2395 #else
2396 #ifdef HAS_SETRESUID
2397       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2398 #else
2399         if (PL_uid == PL_euid) {                /* special case $< = $> */
2400 #ifdef PERL_DARWIN
2401             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2402             if (PL_uid != 0 && PerlProc_getuid() == 0)
2403                 (void)PerlProc_setuid(0);
2404 #endif
2405             (void)PerlProc_setuid(PL_uid);
2406         } else {
2407             PL_uid = PerlProc_getuid();
2408             Perl_croak(aTHX_ "setruid() not implemented");
2409         }
2410 #endif
2411 #endif
2412 #endif
2413         PL_uid = PerlProc_getuid();
2414         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2415         break;
2416     case '>':
2417         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2418         if (PL_delaymagic) {
2419             PL_delaymagic |= DM_EUID;
2420             break;                              /* don't do magic till later */
2421         }
2422 #ifdef HAS_SETEUID
2423         (void)seteuid((Uid_t)PL_euid);
2424 #else
2425 #ifdef HAS_SETREUID
2426         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2427 #else
2428 #ifdef HAS_SETRESUID
2429         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2430 #else
2431         if (PL_euid == PL_uid)          /* special case $> = $< */
2432             PerlProc_setuid(PL_euid);
2433         else {
2434             PL_euid = PerlProc_geteuid();
2435             Perl_croak(aTHX_ "seteuid() not implemented");
2436         }
2437 #endif
2438 #endif
2439 #endif
2440         PL_euid = PerlProc_geteuid();
2441         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2442         break;
2443     case '(':
2444         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2445         if (PL_delaymagic) {
2446             PL_delaymagic |= DM_RGID;
2447             break;                              /* don't do magic till later */
2448         }
2449 #ifdef HAS_SETRGID
2450         (void)setrgid((Gid_t)PL_gid);
2451 #else
2452 #ifdef HAS_SETREGID
2453         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2454 #else
2455 #ifdef HAS_SETRESGID
2456       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2457 #else
2458         if (PL_gid == PL_egid)                  /* special case $( = $) */
2459             (void)PerlProc_setgid(PL_gid);
2460         else {
2461             PL_gid = PerlProc_getgid();
2462             Perl_croak(aTHX_ "setrgid() not implemented");
2463         }
2464 #endif
2465 #endif
2466 #endif
2467         PL_gid = PerlProc_getgid();
2468         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2469         break;
2470     case ')':
2471 #ifdef HAS_SETGROUPS
2472         {
2473             const char *p = SvPV_const(sv, len);
2474             Groups_t *gary = NULL;
2475
2476             while (isSPACE(*p))
2477                 ++p;
2478             PL_egid = Atol(p);
2479             for (i = 0; i < NGROUPS; ++i) {
2480                 while (*p && !isSPACE(*p))
2481                     ++p;
2482                 while (isSPACE(*p))
2483                     ++p;
2484                 if (!*p)
2485                     break;
2486                 if(!gary)
2487                     Newx(gary, i + 1, Groups_t);
2488                 else
2489                     Renew(gary, i + 1, Groups_t);
2490                 gary[i] = Atol(p);
2491             }
2492             if (i)
2493                 (void)setgroups(i, gary);
2494             if (gary)
2495                 Safefree(gary);
2496         }
2497 #else  /* HAS_SETGROUPS */
2498         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2499 #endif /* HAS_SETGROUPS */
2500         if (PL_delaymagic) {
2501             PL_delaymagic |= DM_EGID;
2502             break;                              /* don't do magic till later */
2503         }
2504 #ifdef HAS_SETEGID
2505         (void)setegid((Gid_t)PL_egid);
2506 #else
2507 #ifdef HAS_SETREGID
2508         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2509 #else
2510 #ifdef HAS_SETRESGID
2511         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2512 #else
2513         if (PL_egid == PL_gid)                  /* special case $) = $( */
2514             (void)PerlProc_setgid(PL_egid);
2515         else {
2516             PL_egid = PerlProc_getegid();
2517             Perl_croak(aTHX_ "setegid() not implemented");
2518         }
2519 #endif
2520 #endif
2521 #endif
2522         PL_egid = PerlProc_getegid();
2523         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2524         break;
2525     case ':':
2526         PL_chopset = SvPV_force(sv,len);
2527         break;
2528 #ifndef MACOS_TRADITIONAL
2529     case '0':
2530         LOCK_DOLLARZERO_MUTEX;
2531 #ifdef HAS_SETPROCTITLE
2532         /* The BSDs don't show the argv[] in ps(1) output, they
2533          * show a string from the process struct and provide
2534          * the setproctitle() routine to manipulate that. */
2535         if (PL_origalen != 1) {
2536             s = SvPV_const(sv, len);
2537 #   if __FreeBSD_version > 410001
2538             /* The leading "-" removes the "perl: " prefix,
2539              * but not the "(perl) suffix from the ps(1)
2540              * output, because that's what ps(1) shows if the
2541              * argv[] is modified. */
2542             setproctitle("-%s", s);
2543 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2544             /* This doesn't really work if you assume that
2545              * $0 = 'foobar'; will wipe out 'perl' from the $0
2546              * because in ps(1) output the result will be like
2547              * sprintf("perl: %s (perl)", s)
2548              * I guess this is a security feature:
2549              * one (a user process) cannot get rid of the original name.
2550              * --jhi */
2551             setproctitle("%s", s);
2552 #   endif
2553         }
2554 #endif
2555 #if defined(__hpux) && defined(PSTAT_SETCMD)
2556         if (PL_origalen != 1) {
2557              union pstun un;
2558              s = SvPV_const(sv, len);
2559              un.pst_command = (char *)s;
2560              pstat(PSTAT_SETCMD, un, len, 0, 0);
2561         }
2562 #endif
2563         if (PL_origalen > 1) {
2564             /* PL_origalen is set in perl_parse(). */
2565             s = SvPV_force(sv,len);
2566             if (len >= (STRLEN)PL_origalen-1) {
2567                 /* Longer than original, will be truncated. We assume that
2568                  * PL_origalen bytes are available. */
2569                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2570             }
2571             else {
2572                 /* Shorter than original, will be padded. */
2573                 Copy(s, PL_origargv[0], len, char);
2574                 PL_origargv[0][len] = 0;
2575                 memset(PL_origargv[0] + len + 1,
2576                        /* Is the space counterintuitive?  Yes.
2577                         * (You were expecting \0?)
2578                         * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2579                         * --jhi */
2580                        (int)' ',
2581                        PL_origalen - len - 1);
2582             }
2583             PL_origargv[0][PL_origalen-1] = 0;
2584             for (i = 1; i < PL_origargc; i++)
2585                 PL_origargv[i] = 0;
2586         }
2587         UNLOCK_DOLLARZERO_MUTEX;
2588         break;
2589 #endif
2590     }
2591     return 0;
2592 }
2593
2594 I32
2595 Perl_whichsig(pTHX_ const char *sig)
2596 {
2597     register char* const* sigv;
2598     PERL_UNUSED_CONTEXT;
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 = NULL;
2628     SV *sv = NULL;
2629     SV * const tSv = PL_Sv;
2630     CV *cv = NULL;
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_NN(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_ NULL);
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  */