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 **svp = AvARRAY(av);
2039     PERL_UNUSED_ARG(sv);
2040
2041     if (svp) {
2042         SV *const *const last = svp + AvFILLp(av);
2043
2044         while (svp <= last) {
2045             if (*svp) {
2046                 SV *const referrer = *svp;
2047                 if (SvWEAKREF(referrer)) {
2048                     /* XXX Should we check that it hasn't changed? */
2049                     SvRV_set(referrer, 0);
2050                     SvOK_off(referrer);
2051                     SvWEAKREF_off(referrer);
2052                 } else if (SvTYPE(referrer) == SVt_PVGV ||
2053                            SvTYPE(referrer) == SVt_PVLV) {
2054                     /* You lookin' at me?  */
2055                     assert(GvSTASH(referrer));
2056                     assert(GvSTASH(referrer) == (HV*)sv);
2057                     GvSTASH(referrer) = 0;
2058                 } else {
2059                     Perl_croak(aTHX_
2060                                "panic: magic_killbackrefs (flags=%"UVxf")",
2061                                SvFLAGS(referrer));
2062                 }
2063
2064                 *svp = Nullsv;
2065             }
2066             svp++;
2067         }
2068     }
2069     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2070     return 0;
2071 }
2072
2073 int
2074 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2075 {
2076     mg->mg_len = -1;
2077     SvSCREAM_off(sv);
2078     return 0;
2079 }
2080
2081 int
2082 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2083 {
2084     PERL_UNUSED_ARG(mg);
2085     sv_unmagic(sv, PERL_MAGIC_bm);
2086     SvVALID_off(sv);
2087     return 0;
2088 }
2089
2090 int
2091 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2092 {
2093     PERL_UNUSED_ARG(mg);
2094     sv_unmagic(sv, PERL_MAGIC_fm);
2095     SvCOMPILED_off(sv);
2096     return 0;
2097 }
2098
2099 int
2100 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2101 {
2102     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2103
2104     if (uf && uf->uf_set)
2105         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2106     return 0;
2107 }
2108
2109 int
2110 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2111 {
2112     PERL_UNUSED_ARG(mg);
2113     sv_unmagic(sv, PERL_MAGIC_qr);
2114     return 0;
2115 }
2116
2117 int
2118 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2119 {
2120     regexp * const re = (regexp *)mg->mg_obj;
2121     PERL_UNUSED_ARG(sv);
2122
2123     ReREFCNT_dec(re);
2124     return 0;
2125 }
2126
2127 #ifdef USE_LOCALE_COLLATE
2128 int
2129 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2130 {
2131     /*
2132      * RenE<eacute> Descartes said "I think not."
2133      * and vanished with a faint plop.
2134      */
2135     PERL_UNUSED_ARG(sv);
2136     if (mg->mg_ptr) {
2137         Safefree(mg->mg_ptr);
2138         mg->mg_ptr = NULL;
2139         mg->mg_len = -1;
2140     }
2141     return 0;
2142 }
2143 #endif /* USE_LOCALE_COLLATE */
2144
2145 /* Just clear the UTF-8 cache data. */
2146 int
2147 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2148 {
2149     PERL_UNUSED_ARG(sv);
2150     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2151     mg->mg_ptr = 0;
2152     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2153     return 0;
2154 }
2155
2156 int
2157 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2158 {
2159     register const char *s;
2160     I32 i;
2161     STRLEN len;
2162     switch (*mg->mg_ptr) {
2163     case '\001':        /* ^A */
2164         sv_setsv(PL_bodytarget, sv);
2165         break;
2166     case '\003':        /* ^C */
2167         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2168         break;
2169
2170     case '\004':        /* ^D */
2171 #ifdef DEBUGGING
2172         s = SvPV_nolen_const(sv);
2173         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2174         DEBUG_x(dump_all());
2175 #else
2176         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2177 #endif
2178         break;
2179     case '\005':  /* ^E */
2180         if (*(mg->mg_ptr+1) == '\0') {
2181 #ifdef MACOS_TRADITIONAL
2182             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2183 #else
2184 #  ifdef VMS
2185             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2186 #  else
2187 #    ifdef WIN32
2188             SetLastError( SvIV(sv) );
2189 #    else
2190 #      ifdef OS2
2191             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2192 #      else
2193             /* will anyone ever use this? */
2194             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2195 #      endif
2196 #    endif
2197 #  endif
2198 #endif
2199         }
2200         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2201             if (PL_encoding)
2202                 SvREFCNT_dec(PL_encoding);
2203             if (SvOK(sv) || SvGMAGICAL(sv)) {
2204                 PL_encoding = newSVsv(sv);
2205             }
2206             else {
2207                 PL_encoding = Nullsv;
2208             }
2209         }
2210         break;
2211     case '\006':        /* ^F */
2212         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2213         break;
2214     case '\010':        /* ^H */
2215         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2216         break;
2217     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2218         Safefree(PL_inplace);
2219         PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2220     case '\017':        /* ^O */
2221         if (*(mg->mg_ptr+1) == '\0') {
2222             Safefree(PL_osname);
2223             PL_osname = Nullch;
2224             if (SvOK(sv)) {
2225                 TAINT_PROPER("assigning to $^O");
2226                 PL_osname = savesvpv(sv);
2227             }
2228         }
2229         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2230             if (!PL_compiling.cop_io)
2231                 PL_compiling.cop_io = newSVsv(sv);
2232             else
2233                 sv_setsv(PL_compiling.cop_io,sv);
2234         }
2235         break;
2236     case '\020':        /* ^P */
2237         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2238         if (PL_perldb && !PL_DBsingle)
2239             init_debugger();
2240         break;
2241     case '\024':        /* ^T */
2242 #ifdef BIG_TIME
2243         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2244 #else
2245         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2246 #endif
2247         break;
2248     case '\027':        /* ^W & $^WARNING_BITS */
2249         if (*(mg->mg_ptr+1) == '\0') {
2250             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2251                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2252                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2253                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2254             }
2255         }
2256         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2257             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2258                 if (!SvPOK(sv) && PL_localizing) {
2259                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2260                     PL_compiling.cop_warnings = pWARN_NONE;
2261                     break;
2262                 }
2263                 {
2264                     STRLEN len, i;
2265                     int accumulate = 0 ;
2266                     int any_fatals = 0 ;
2267                     const char * const ptr = SvPV_const(sv, len) ;
2268                     for (i = 0 ; i < len ; ++i) {
2269                         accumulate |= ptr[i] ;
2270                         any_fatals |= (ptr[i] & 0xAA) ;
2271                     }
2272                     if (!accumulate)
2273                         PL_compiling.cop_warnings = pWARN_NONE;
2274                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2275                         PL_compiling.cop_warnings = pWARN_ALL;
2276                         PL_dowarn |= G_WARN_ONCE ;
2277                     }
2278                     else {
2279                         if (specialWARN(PL_compiling.cop_warnings))
2280                             PL_compiling.cop_warnings = newSVsv(sv) ;
2281                         else
2282                             sv_setsv(PL_compiling.cop_warnings, sv);
2283                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2284                             PL_dowarn |= G_WARN_ONCE ;
2285                     }
2286
2287                 }
2288             }
2289         }
2290         break;
2291     case '.':
2292         if (PL_localizing) {
2293             if (PL_localizing == 1)
2294                 SAVESPTR(PL_last_in_gv);
2295         }
2296         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2297             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2298         break;
2299     case '^':
2300         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2301         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2302         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2303         break;
2304     case '~':
2305         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2306         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2307         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2308         break;
2309     case '=':
2310         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2311         break;
2312     case '-':
2313         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2314         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2315             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2316         break;
2317     case '%':
2318         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2319         break;
2320     case '|':
2321         {
2322             IO * const io = GvIOp(PL_defoutgv);
2323             if(!io)
2324               break;
2325             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2326                 IoFLAGS(io) &= ~IOf_FLUSH;
2327             else {
2328                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2329                     PerlIO *ofp = IoOFP(io);
2330                     if (ofp)
2331                         (void)PerlIO_flush(ofp);
2332                     IoFLAGS(io) |= IOf_FLUSH;
2333                 }
2334             }
2335         }
2336         break;
2337     case '/':
2338         SvREFCNT_dec(PL_rs);
2339         PL_rs = newSVsv(sv);
2340         break;
2341     case '\\':
2342         if (PL_ors_sv)
2343             SvREFCNT_dec(PL_ors_sv);
2344         if (SvOK(sv) || SvGMAGICAL(sv)) {
2345             PL_ors_sv = newSVsv(sv);
2346         }
2347         else {
2348             PL_ors_sv = Nullsv;
2349         }
2350         break;
2351     case ',':
2352         if (PL_ofs_sv)
2353             SvREFCNT_dec(PL_ofs_sv);
2354         if (SvOK(sv) || SvGMAGICAL(sv)) {
2355             PL_ofs_sv = newSVsv(sv);
2356         }
2357         else {
2358             PL_ofs_sv = Nullsv;
2359         }
2360         break;
2361     case '[':
2362         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2363         break;
2364     case '?':
2365 #ifdef COMPLEX_STATUS
2366         if (PL_localizing == 2) {
2367             PL_statusvalue = LvTARGOFF(sv);
2368             PL_statusvalue_vms = LvTARGLEN(sv);
2369         }
2370         else
2371 #endif
2372 #ifdef VMSISH_STATUS
2373         if (VMSISH_STATUS)
2374             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2375         else
2376 #endif
2377             STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2378         break;
2379     case '!':
2380         {
2381 #ifdef VMS
2382 #   define PERL_VMS_BANG vaxc$errno
2383 #else
2384 #   define PERL_VMS_BANG 0
2385 #endif
2386         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2387                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2388         }
2389         break;
2390     case '<':
2391         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2392         if (PL_delaymagic) {
2393             PL_delaymagic |= DM_RUID;
2394             break;                              /* don't do magic till later */
2395         }
2396 #ifdef HAS_SETRUID
2397         (void)setruid((Uid_t)PL_uid);
2398 #else
2399 #ifdef HAS_SETREUID
2400         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2401 #else
2402 #ifdef HAS_SETRESUID
2403       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2404 #else
2405         if (PL_uid == PL_euid) {                /* special case $< = $> */
2406 #ifdef PERL_DARWIN
2407             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2408             if (PL_uid != 0 && PerlProc_getuid() == 0)
2409                 (void)PerlProc_setuid(0);
2410 #endif
2411             (void)PerlProc_setuid(PL_uid);
2412         } else {
2413             PL_uid = PerlProc_getuid();
2414             Perl_croak(aTHX_ "setruid() not implemented");
2415         }
2416 #endif
2417 #endif
2418 #endif
2419         PL_uid = PerlProc_getuid();
2420         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2421         break;
2422     case '>':
2423         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2424         if (PL_delaymagic) {
2425             PL_delaymagic |= DM_EUID;
2426             break;                              /* don't do magic till later */
2427         }
2428 #ifdef HAS_SETEUID
2429         (void)seteuid((Uid_t)PL_euid);
2430 #else
2431 #ifdef HAS_SETREUID
2432         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2433 #else
2434 #ifdef HAS_SETRESUID
2435         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2436 #else
2437         if (PL_euid == PL_uid)          /* special case $> = $< */
2438             PerlProc_setuid(PL_euid);
2439         else {
2440             PL_euid = PerlProc_geteuid();
2441             Perl_croak(aTHX_ "seteuid() not implemented");
2442         }
2443 #endif
2444 #endif
2445 #endif
2446         PL_euid = PerlProc_geteuid();
2447         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2448         break;
2449     case '(':
2450         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2451         if (PL_delaymagic) {
2452             PL_delaymagic |= DM_RGID;
2453             break;                              /* don't do magic till later */
2454         }
2455 #ifdef HAS_SETRGID
2456         (void)setrgid((Gid_t)PL_gid);
2457 #else
2458 #ifdef HAS_SETREGID
2459         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2460 #else
2461 #ifdef HAS_SETRESGID
2462       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2463 #else
2464         if (PL_gid == PL_egid)                  /* special case $( = $) */
2465             (void)PerlProc_setgid(PL_gid);
2466         else {
2467             PL_gid = PerlProc_getgid();
2468             Perl_croak(aTHX_ "setrgid() not implemented");
2469         }
2470 #endif
2471 #endif
2472 #endif
2473         PL_gid = PerlProc_getgid();
2474         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2475         break;
2476     case ')':
2477 #ifdef HAS_SETGROUPS
2478         {
2479             const char *p = SvPV_const(sv, len);
2480             Groups_t gary[NGROUPS];
2481
2482             while (isSPACE(*p))
2483                 ++p;
2484             PL_egid = Atol(p);
2485             for (i = 0; i < NGROUPS; ++i) {
2486                 while (*p && !isSPACE(*p))
2487                     ++p;
2488                 while (isSPACE(*p))
2489                     ++p;
2490                 if (!*p)
2491                     break;
2492                 gary[i] = Atol(p);
2493             }
2494             if (i)
2495                 (void)setgroups(i, gary);
2496         }
2497 #else  /* HAS_SETGROUPS */
2498         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2499 #endif /* HAS_SETGROUPS */
2500         if (PL_delaymagic) {
2501             PL_delaymagic |= DM_EGID;
2502             break;                              /* don't do magic till later */
2503         }
2504 #ifdef HAS_SETEGID
2505         (void)setegid((Gid_t)PL_egid);
2506 #else
2507 #ifdef HAS_SETREGID
2508         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2509 #else
2510 #ifdef HAS_SETRESGID
2511         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2512 #else
2513         if (PL_egid == PL_gid)                  /* special case $) = $( */
2514             (void)PerlProc_setgid(PL_egid);
2515         else {
2516             PL_egid = PerlProc_getegid();
2517             Perl_croak(aTHX_ "setegid() not implemented");
2518         }
2519 #endif
2520 #endif
2521 #endif
2522         PL_egid = PerlProc_getegid();
2523         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2524         break;
2525     case ':':
2526         PL_chopset = SvPV_force(sv,len);
2527         break;
2528 #ifndef MACOS_TRADITIONAL
2529     case '0':
2530         LOCK_DOLLARZERO_MUTEX;
2531 #ifdef HAS_SETPROCTITLE
2532         /* The BSDs don't show the argv[] in ps(1) output, they
2533          * show a string from the process struct and provide
2534          * the setproctitle() routine to manipulate that. */
2535         {
2536             s = SvPV_const(sv, len);
2537 #   if __FreeBSD_version > 410001
2538             /* The leading "-" removes the "perl: " prefix,
2539              * but not the "(perl) suffix from the ps(1)
2540              * output, because that's what ps(1) shows if the
2541              * argv[] is modified. */
2542             setproctitle("-%s", s);
2543 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2544             /* This doesn't really work if you assume that
2545              * $0 = 'foobar'; will wipe out 'perl' from the $0
2546              * because in ps(1) output the result will be like
2547              * sprintf("perl: %s (perl)", s)
2548              * I guess this is a security feature:
2549              * one (a user process) cannot get rid of the original name.
2550              * --jhi */
2551             setproctitle("%s", s);
2552 #   endif
2553         }
2554 #endif
2555 #if defined(__hpux) && defined(PSTAT_SETCMD)
2556         {
2557              union pstun un;
2558              s = SvPV_const(sv, len);
2559              un.pst_command = (char *)s;
2560              pstat(PSTAT_SETCMD, un, len, 0, 0);
2561         }
2562 #endif
2563         /* PL_origalen is set in perl_parse(). */
2564         s = SvPV_force(sv,len);
2565         if (len >= (STRLEN)PL_origalen-1) {
2566             /* Longer than original, will be truncated. We assume that
2567              * PL_origalen bytes are available. */
2568             Copy(s, PL_origargv[0], PL_origalen-1, char);
2569         }
2570         else {
2571             /* Shorter than original, will be padded. */
2572             Copy(s, PL_origargv[0], len, char);
2573             PL_origargv[0][len] = 0;
2574             memset(PL_origargv[0] + len + 1,
2575                    /* Is the space counterintuitive?  Yes.
2576                     * (You were expecting \0?)
2577                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2578                     * --jhi */
2579                    (int)' ',
2580                    PL_origalen - len - 1);
2581         }
2582         PL_origargv[0][PL_origalen-1] = 0;
2583         for (i = 1; i < PL_origargc; i++)
2584             PL_origargv[i] = 0;
2585         UNLOCK_DOLLARZERO_MUTEX;
2586         break;
2587 #endif
2588     }
2589     return 0;
2590 }
2591
2592 I32
2593 Perl_whichsig(pTHX_ const char *sig)
2594 {
2595     register char* const* sigv;
2596
2597     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2598         if (strEQ(sig,*sigv))
2599             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2600 #ifdef SIGCLD
2601     if (strEQ(sig,"CHLD"))
2602         return SIGCLD;
2603 #endif
2604 #ifdef SIGCHLD
2605     if (strEQ(sig,"CLD"))
2606         return SIGCHLD;
2607 #endif
2608     return -1;
2609 }
2610
2611 Signal_t
2612 Perl_sighandler(int sig)
2613 {
2614 #ifdef PERL_GET_SIG_CONTEXT
2615     dTHXa(PERL_GET_SIG_CONTEXT);
2616 #else
2617     dTHX;
2618 #endif
2619     dSP;
2620     GV *gv = Nullgv;
2621     SV *sv = Nullsv;
2622     SV * const tSv = PL_Sv;
2623     CV *cv = Nullcv;
2624     OP *myop = PL_op;
2625     U32 flags = 0;
2626     XPV * const tXpv = PL_Xpv;
2627
2628     if (PL_savestack_ix + 15 <= PL_savestack_max)
2629         flags |= 1;
2630     if (PL_markstack_ptr < PL_markstack_max - 2)
2631         flags |= 4;
2632     if (PL_scopestack_ix < PL_scopestack_max - 3)
2633         flags |= 16;
2634
2635     if (!PL_psig_ptr[sig]) {
2636                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2637                                  PL_sig_name[sig]);
2638                 exit(sig);
2639         }
2640
2641     /* Max number of items pushed there is 3*n or 4. We cannot fix
2642        infinity, so we fix 4 (in fact 5): */
2643     if (flags & 1) {
2644         PL_savestack_ix += 5;           /* Protect save in progress. */
2645         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2646     }
2647     if (flags & 4)
2648         PL_markstack_ptr++;             /* Protect mark. */
2649     if (flags & 16)
2650         PL_scopestack_ix += 1;
2651     /* sv_2cv is too complicated, try a simpler variant first: */
2652     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2653         || SvTYPE(cv) != SVt_PVCV) {
2654         HV *st;
2655         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2656     }
2657
2658     if (!cv || !CvROOT(cv)) {
2659         if (ckWARN(WARN_SIGNAL))
2660             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2661                 PL_sig_name[sig], (gv ? GvENAME(gv)
2662                                 : ((cv && CvGV(cv))
2663                                    ? GvENAME(CvGV(cv))
2664                                    : "__ANON__")));
2665         goto cleanup;
2666     }
2667
2668     if(PL_psig_name[sig]) {
2669         sv = SvREFCNT_inc(PL_psig_name[sig]);
2670         flags |= 64;
2671 #if !defined(PERL_IMPLICIT_CONTEXT)
2672         PL_sig_sv = sv;
2673 #endif
2674     } else {
2675         sv = sv_newmortal();
2676         sv_setpv(sv,PL_sig_name[sig]);
2677     }
2678
2679     PUSHSTACKi(PERLSI_SIGNAL);
2680     PUSHMARK(SP);
2681     PUSHs(sv);
2682     PUTBACK;
2683
2684     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2685
2686     POPSTACK;
2687     if (SvTRUE(ERRSV)) {
2688 #ifndef PERL_MICRO
2689 #ifdef HAS_SIGPROCMASK
2690         /* Handler "died", for example to get out of a restart-able read().
2691          * Before we re-do that on its behalf re-enable the signal which was
2692          * blocked by the system when we entered.
2693          */
2694         sigset_t set;
2695         sigemptyset(&set);
2696         sigaddset(&set,sig);
2697         sigprocmask(SIG_UNBLOCK, &set, NULL);
2698 #else
2699         /* Not clear if this will work */
2700         (void)rsignal(sig, SIG_IGN);
2701         (void)rsignal(sig, PL_csighandlerp);
2702 #endif
2703 #endif /* !PERL_MICRO */
2704         DieNull;
2705     }
2706 cleanup:
2707     if (flags & 1)
2708         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2709     if (flags & 4)
2710         PL_markstack_ptr--;
2711     if (flags & 16)
2712         PL_scopestack_ix -= 1;
2713     if (flags & 64)
2714         SvREFCNT_dec(sv);
2715     PL_op = myop;                       /* Apparently not needed... */
2716
2717     PL_Sv = tSv;                        /* Restore global temporaries. */
2718     PL_Xpv = tXpv;
2719     return;
2720 }
2721
2722
2723 static void
2724 S_restore_magic(pTHX_ const void *p)
2725 {
2726     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2727     SV* const sv = mgs->mgs_sv;
2728
2729     if (!sv)
2730         return;
2731
2732     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2733     {
2734 #ifdef PERL_OLD_COPY_ON_WRITE
2735         /* While magic was saved (and off) sv_setsv may well have seen
2736            this SV as a prime candidate for COW.  */
2737         if (SvIsCOW(sv))
2738             sv_force_normal(sv);
2739 #endif
2740
2741         if (mgs->mgs_flags)
2742             SvFLAGS(sv) |= mgs->mgs_flags;
2743         else
2744             mg_magical(sv);
2745         if (SvGMAGICAL(sv))
2746             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2747     }
2748
2749     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2750
2751     /* If we're still on top of the stack, pop us off.  (That condition
2752      * will be satisfied if restore_magic was called explicitly, but *not*
2753      * if it's being called via leave_scope.)
2754      * The reason for doing this is that otherwise, things like sv_2cv()
2755      * may leave alloc gunk on the savestack, and some code
2756      * (e.g. sighandler) doesn't expect that...
2757      */
2758     if (PL_savestack_ix == mgs->mgs_ss_ix)
2759     {
2760         I32 popval = SSPOPINT;
2761         assert(popval == SAVEt_DESTRUCTOR_X);
2762         PL_savestack_ix -= 2;
2763         popval = SSPOPINT;
2764         assert(popval == SAVEt_ALLOC);
2765         popval = SSPOPINT;
2766         PL_savestack_ix -= popval;
2767     }
2768
2769 }
2770
2771 static void
2772 S_unwind_handler_stack(pTHX_ const void *p)
2773 {
2774     dVAR;
2775     const U32 flags = *(const U32*)p;
2776
2777     if (flags & 1)
2778         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2779     /* cxstack_ix-- Not needed, die already unwound it. */
2780 #if !defined(PERL_IMPLICIT_CONTEXT)
2781     if (flags & 64)
2782         SvREFCNT_dec(PL_sig_sv);
2783 #endif
2784 }
2785
2786 /*
2787  * Local variables:
2788  * c-indentation-style: bsd
2789  * c-basic-offset: 4
2790  * indent-tabs-mode: t
2791  * End:
2792  *
2793  * ex: set ts=8 sts=4 sw=4 noet:
2794  */