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