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