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