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 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
  56 Signal_t Perl_csighandler(int sig, ...);
  57 #else
  58 Signal_t Perl_csighandler(int sig);
  59 #endif
  60
  61 #ifdef __Lynx__
  62 /* Missing protos on LynxOS */
  63 void setruid(uid_t id);
  64 void seteuid(uid_t id);
  65 void setrgid(uid_t id);
  66 void setegid(uid_t id);
  67 #endif
  68
  69 /*
  70  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  71  */
  72
  73 struct magic_state {
  74     SV* mgs_sv;
  75     U32 mgs_flags;
  76     I32 mgs_ss_ix;
  77 };
  78 /* MGS is typedef'ed to struct magic_state in perl.h */
  79
  80 STATIC void
  81 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
  82 {
  83     MGS* mgs;
  84     assert(SvMAGICAL(sv));
  85 #ifdef PERL_OLD_COPY_ON_WRITE
  86     /* Turning READONLY off for a copy-on-write scalar is a bad idea.  */
  87     if (SvIsCOW(sv))
  88       sv_force_normal_flags(sv, 0);
  89 #endif
  90
  91     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
  92
  93     mgs = SSPTR(mgs_ix, MGS*);
  94     mgs->mgs_sv = sv;
  95     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  96     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
  97
  98     SvMAGICAL_off(sv);
  99     SvREADONLY_off(sv);
 100     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 101 }
 102
 103 /*
 104 =for apidoc mg_magical
 105
 106 Turns on the magical status of an SV.  See C<sv_magic>.
 107
 108 =cut
 109 */
 110
 111 void
 112 Perl_mg_magical(pTHX_ SV *sv)
 113 {
 114     const MAGIC* mg;
 115     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 116         const MGVTBL* const vtbl = mg->mg_virtual;
 117         if (vtbl) {
 118             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 119                 SvGMAGICAL_on(sv);
 120             if (vtbl->svt_set)
 121                 SvSMAGICAL_on(sv);
 122             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
 123                 SvRMAGICAL_on(sv);
 124         }
 125     }
 126 }
 127
 128 /*
 129 =for apidoc mg_get
 130
 131 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 132
 133 =cut
 134 */
 135
 136 int
 137 Perl_mg_get(pTHX_ SV *sv)
 138 {
 139     const I32 mgs_ix = SSNEW(sizeof(MGS));
 140     const bool was_temp = (bool)SvTEMP(sv);
 141     int have_new = 0;
 142     MAGIC *newmg, *head, *cur, *mg;
 143     /* guard against sv having being freed midway by holding a private
 144        reference. */
 145
 146     /* sv_2mortal has this side effect of turning on the TEMP flag, which can
 147        cause the SV's buffer to get stolen (and maybe other stuff).
 148        So restore it.
 149     */
 150     sv_2mortal(SvREFCNT_inc(sv));
 151     if (!was_temp) {
 152         SvTEMP_off(sv);
 153     }
 154
 155     save_magic(mgs_ix, sv);
 156
 157     /* We must call svt_get(sv, mg) for each valid entry in the linked
 158        list of magic. svt_get() may delete the current entry, add new
 159        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 160
 161     newmg = cur = head = mg = SvMAGIC(sv);
 162     while (mg) {
 163         const MGVTBL * const vtbl = mg->mg_virtual;
 164
 165         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 166             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 167
 168             /* guard against magic having been deleted - eg FETCH calling
 169              * untie */
 170             if (!SvMAGIC(sv))
 171                 break;
 172
 173             /* Don't restore the flags for this entry if it was deleted. */
 174             if (mg->mg_flags & MGf_GSKIP)
 175                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
 176         }
 177
 178         mg = mg->mg_moremagic;
 179
 180         if (have_new) {
 181             /* Have we finished with the new entries we saw? Start again
 182                where we left off (unless there are more new entries). */
 183             if (mg == head) {
 184                 have_new = 0;
 185                 mg   = cur;
 186                 head = newmg;
 187             }
 188         }
 189
 190         /* Were any new entries added? */
 191         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
 192             have_new = 1;
 193             cur = mg;
 194             mg  = newmg;
 195         }
 196     }
 197
 198     restore_magic(INT2PTR(void *, (IV)mgs_ix));
 199
 200     if (SvREFCNT(sv) == 1) {
 201         /* We hold the last reference to this SV, which implies that the
 202            SV was deleted as a side effect of the routines we called.  */
 203         SvOK_off(sv);
 204     }
 205     return 0;
 206 }
 207
 208 /*
 209 =for apidoc mg_set
 210
 211 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 212
 213 =cut
 214 */
 215
 216 int
 217 Perl_mg_set(pTHX_ SV *sv)
 218 {
 219     const I32 mgs_ix = SSNEW(sizeof(MGS));
 220     MAGIC* mg;
 221     MAGIC* nextmg;
 222
 223     save_magic(mgs_ix, sv);
 224
 225     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 226         const MGVTBL* vtbl = mg->mg_virtual;
 227         nextmg = mg->mg_moremagic;      /* it may delete itself */
 228         if (mg->mg_flags & MGf_GSKIP) {
 229             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 230             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
 231         }
 232         if (vtbl && vtbl->svt_set)
 233             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
 234     }
 235
 236     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 237     return 0;
 238 }
 239
 240 /*
 241 =for apidoc mg_length
 242
 243 Report on the SV's length.  See C<sv_magic>.
 244
 245 =cut
 246 */
 247
 248 U32
 249 Perl_mg_length(pTHX_ SV *sv)
 250 {
 251     MAGIC* mg;
 252     STRLEN len;
 253
 254     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 255         const MGVTBL * const vtbl = mg->mg_virtual;
 256         if (vtbl && vtbl->svt_len) {
 257             const I32 mgs_ix = SSNEW(sizeof(MGS));
 258             save_magic(mgs_ix, sv);
 259             /* omit MGf_GSKIP -- not changed here */
 260             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 261             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 262             return len;
 263         }
 264     }
 265
 266     if (DO_UTF8(sv)) {
 267         const U8 *s = (U8*)SvPV_const(sv, len);
 268         len = Perl_utf8_length(aTHX_ s, s + len);
 269     }
 270     else
 271         (void)SvPV_const(sv, len);
 272     return len;
 273 }
 274
 275 I32
 276 Perl_mg_size(pTHX_ SV *sv)
 277 {
 278     MAGIC* mg;
 279
 280     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 281         const MGVTBL* const vtbl = mg->mg_virtual;
 282         if (vtbl && vtbl->svt_len) {
 283             const I32 mgs_ix = SSNEW(sizeof(MGS));
 284             I32 len;
 285             save_magic(mgs_ix, sv);
 286             /* omit MGf_GSKIP -- not changed here */
 287             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 288             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 289             return len;
 290         }
 291     }
 292
 293     switch(SvTYPE(sv)) {
 294         case SVt_PVAV:
 295             return AvFILLp((AV *) sv); /* Fallback to non-tied array */
 296         case SVt_PVHV:
 297             /* FIXME */
 298         default:
 299             Perl_croak(aTHX_ "Size magic not implemented");
 300             break;
 301     }
 302     return 0;
 303 }
 304
 305 /*
 306 =for apidoc mg_clear
 307
 308 Clear something magical that the SV represents.  See C<sv_magic>.
 309
 310 =cut
 311 */
 312
 313 int
 314 Perl_mg_clear(pTHX_ SV *sv)
 315 {
 316     const I32 mgs_ix = SSNEW(sizeof(MGS));
 317     MAGIC* mg;
 318
 319     save_magic(mgs_ix, sv);
 320
 321     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 322         const MGVTBL* const vtbl = mg->mg_virtual;
 323         /* omit GSKIP -- never set here */
 324
 325         if (vtbl && vtbl->svt_clear)
 326             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 327     }
 328
 329     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 330     return 0;
 331 }
 332
 333 /*
 334 =for apidoc mg_find
 335
 336 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 337
 338 =cut
 339 */
 340
 341 MAGIC*
 342 Perl_mg_find(pTHX_ const SV *sv, int type)
 343 {
 344     if (sv) {
 345         MAGIC *mg;
 346         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 347             if (mg->mg_type == type)
 348                 return mg;
 349         }
 350     }
 351     return 0;
 352 }
 353
 354 /*
 355 =for apidoc mg_copy
 356
 357 Copies the magic from one SV to another.  See C<sv_magic>.
 358
 359 =cut
 360 */
 361
 362 int
 363 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 364 {
 365     int count = 0;
 366     MAGIC* mg;
 367     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 368         const MGVTBL* const vtbl = mg->mg_virtual;
 369         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 370             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 371         }
 372         else {
 373             const char type = mg->mg_type;
 374             if (isUPPER(type)) {
 375                 sv_magic(nsv,
 376                      (type == PERL_MAGIC_tied)
 377                         ? SvTIED_obj(sv, mg)
 378                         : (type == PERL_MAGIC_regdata && mg->mg_obj)
 379                             ? sv
 380                             : mg->mg_obj,
 381                      toLOWER(type), key, klen);
 382                 count++;
 383             }
 384         }
 385     }
 386     return count;
 387 }
 388
 389 /*
 390 =for apidoc mg_localize
 391
 392 Copy some of the magic from an existing SV to new localized version of
 393 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
 394 doesn't (eg taint, pos).
 395
 396 =cut
 397 */
 398
 399 void
 400 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
 401 {
 402     MAGIC *mg;
 403     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 404         const MGVTBL* const vtbl = mg->mg_virtual;
 405         switch (mg->mg_type) {
 406         /* value magic types: don't copy */
 407         case PERL_MAGIC_bm:
 408         case PERL_MAGIC_fm:
 409         case PERL_MAGIC_regex_global:
 410         case PERL_MAGIC_nkeys:
 411 #ifdef USE_LOCALE_COLLATE
 412         case PERL_MAGIC_collxfrm:
 413 #endif
 414         case PERL_MAGIC_qr:
 415         case PERL_MAGIC_taint:
 416         case PERL_MAGIC_vec:
 417         case PERL_MAGIC_vstring:
 418         case PERL_MAGIC_utf8:
 419         case PERL_MAGIC_substr:
 420         case PERL_MAGIC_defelem:
 421         case PERL_MAGIC_arylen:
 422         case PERL_MAGIC_pos:
 423         case PERL_MAGIC_backref:
 424         case PERL_MAGIC_arylen_p:
 425         case PERL_MAGIC_rhash:
 426         case PERL_MAGIC_symtab:
 427             continue;
 428         }
 429
 430         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
 431             /* XXX calling the copy method is probably not correct. DAPM */
 432             (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
 433                                     mg->mg_ptr, mg->mg_len);
 434         }
 435         else {
 436             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 437                             mg->mg_ptr, mg->mg_len);
 438         }
 439         /* container types should remain read-only across localization */
 440         SvFLAGS(nsv) |= SvREADONLY(sv);
 441     }
 442
 443     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 444         SvFLAGS(nsv) |= SvMAGICAL(sv);
 445         PL_localizing = 1;
 446         SvSETMAGIC(nsv);
 447         PL_localizing = 0;
 448     }
 449 }
 450
 451 /*
 452 =for apidoc mg_free
 453
 454 Free any magic storage used by the SV.  See C<sv_magic>.
 455
 456 =cut
 457 */
 458
 459 int
 460 Perl_mg_free(pTHX_ SV *sv)
 461 {
 462     MAGIC* mg;
 463     MAGIC* moremagic;
 464     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 465         const MGVTBL* const vtbl = mg->mg_virtual;
 466         moremagic = mg->mg_moremagic;
 467         if (vtbl && vtbl->svt_free)
 468             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 469         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 470             if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 471                 Safefree(mg->mg_ptr);
 472             else if (mg->mg_len == HEf_SVKEY)
 473                 SvREFCNT_dec((SV*)mg->mg_ptr);
 474         }
 475         if (mg->mg_flags & MGf_REFCOUNTED)
 476             SvREFCNT_dec(mg->mg_obj);
 477         Safefree(mg);
 478     }
 479     SvMAGIC_set(sv, NULL);
 480     return 0;
 481 }
 482
 483 #include <signal.h>
 484
 485 U32
 486 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 487 {
 488     register const REGEXP *rx;
 489     PERL_UNUSED_ARG(sv);
 490
 491     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 492         if (mg->mg_obj)         /* @+ */
 493             return rx->nparens;
 494         else                    /* @- */
 495             return rx->lastparen;
 496     }
 497
 498     return (U32)-1;
 499 }
 500
 501 int
 502 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 503 {
 504     register REGEXP *rx;
 505
 506     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 507         register const I32 paren = mg->mg_len;
 508         register I32 s;
 509         register I32 t;
 510         if (paren < 0)
 511             return 0;
 512         if (paren <= (I32)rx->nparens &&
 513             (s = rx->startp[paren]) != -1 &&
 514             (t = rx->endp[paren]) != -1)
 515             {
 516                 register I32 i;
 517                 if (mg->mg_obj)         /* @+ */
 518                     i = t;
 519                 else                    /* @- */
 520                     i = s;
 521
 522                 if (i > 0 && RX_MATCH_UTF8(rx)) {
 523                     const char * const b = rx->subbeg;
 524                     if (b)
 525                         i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
 526                 }
 527
 528                 sv_setiv(sv, i);
 529             }
 530     }
 531     return 0;
 532 }
 533
 534 int
 535 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 536 {
 537     PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
 538     Perl_croak(aTHX_ PL_no_modify);
 539     NORETURN_FUNCTION_END;
 540 }
 541
 542 U32
 543 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 544 {
 545     register I32 paren;
 546     register I32 i;
 547     register const REGEXP *rx;
 548     I32 s1, t1;
 549
 550     switch (*mg->mg_ptr) {
 551     case '1': case '2': case '3': case '4':
 552     case '5': case '6': case '7': case '8': case '9': case '&':
 553         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 554
 555             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 556           getparen:
 557             if (paren <= (I32)rx->nparens &&
 558                 (s1 = rx->startp[paren]) != -1 &&
 559                 (t1 = rx->endp[paren]) != -1)
 560             {
 561                 i = t1 - s1;
 562               getlen:
 563                 if (i > 0 && RX_MATCH_UTF8(rx)) {
 564                     const char * const s = rx->subbeg + s1;
 565                     const U8 *ep;
 566                     STRLEN el;
 567
 568                     i = t1 - s1;
 569                     if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
 570                         i = el;
 571                 }
 572                 if (i < 0)
 573                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 574                 return i;
 575             }
 576             else {
 577                 if (ckWARN(WARN_UNINITIALIZED))
 578                     report_uninit(sv);
 579             }
 580         }
 581         else {
 582             if (ckWARN(WARN_UNINITIALIZED))
 583                 report_uninit(sv);
 584         }
 585         return 0;
 586     case '+':
 587         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 588             paren = rx->lastparen;
 589             if (paren)
 590                 goto getparen;
 591         }
 592         return 0;
 593     case '\016': /* ^N */
 594         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 595             paren = rx->lastcloseparen;
 596             if (paren)
 597                 goto getparen;
 598         }
 599         return 0;
 600     case '`':
 601         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 602             if (rx->startp[0] != -1) {
 603                 i = rx->startp[0];
 604                 if (i > 0) {
 605                     s1 = 0;
 606                     t1 = i;
 607                     goto getlen;
 608                 }
 609             }
 610         }
 611         return 0;
 612     case '\'':
 613         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 614             if (rx->endp[0] != -1) {
 615                 i = rx->sublen - rx->endp[0];
 616                 if (i > 0) {
 617                     s1 = rx->endp[0];
 618                     t1 = rx->sublen;
 619                     goto getlen;
 620                 }
 621             }
 622         }
 623         return 0;
 624     }
 625     magic_get(sv,mg);
 626     if (!SvPOK(sv) && SvNIOK(sv)) {
 627         sv_2pv(sv, 0);
 628     }
 629     if (SvPOK(sv))
 630         return SvCUR(sv);
 631     return 0;
 632 }
 633
 634 #define SvRTRIM(sv) STMT_START { \
 635     STRLEN len = SvCUR(sv); \
 636     while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
 637         --len; \
 638     SvCUR_set(sv, len); \
 639 } STMT_END
 640
 641 int
 642 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 643 {
 644     dVAR;
 645     register I32 paren;
 646     register char *s = NULL;
 647     register I32 i;
 648     register REGEXP *rx;
 649     const char * const remaining = mg->mg_ptr + 1;
 650     const char nextchar = *remaining;
 651
 652     switch (*mg->mg_ptr) {
 653     case '\001':                /* ^A */
 654         sv_setsv(sv, PL_bodytarget);
 655         break;
 656     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 657         if (nextchar == '\0') {
 658             sv_setiv(sv, (IV)PL_minus_c);
 659         }
 660         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 661             sv_setiv(sv, (IV)STATUS_NATIVE);
 662         }
 663         break;
 664
 665     case '\004':                /* ^D */
 666         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 667         break;
 668     case '\005':  /* ^E */
 669          if (nextchar == '\0') {
 670 #ifdef MACOS_TRADITIONAL
 671              {
 672                   char msg[256];
 673
 674                   sv_setnv(sv,(double)gMacPerl_OSErr);
 675                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 676              }
 677 #else
 678 #ifdef VMS
 679              {
 680 #                 include <descrip.h>
 681 #                 include <starlet.h>
 682                   char msg[255];
 683                   $DESCRIPTOR(msgdsc,msg);
 684                   sv_setnv(sv,(NV) vaxc$errno);
 685                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 686                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 687                   else
 688                        sv_setpvn(sv,"",0);
 689              }
 690 #else
 691 #ifdef OS2
 692              if (!(_emx_env & 0x200)) { /* Under DOS */
 693                   sv_setnv(sv, (NV)errno);
 694                   sv_setpv(sv, errno ? Strerror(errno) : "");
 695              } else {
 696                   if (errno != errno_isOS2) {
 697                        const int tmp = _syserrno();
 698                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 699                             Perl_rc = tmp;
 700                   }
 701                   sv_setnv(sv, (NV)Perl_rc);
 702                   sv_setpv(sv, os2error(Perl_rc));
 703              }
 704 #else
 705 #ifdef WIN32
 706              {
 707                   DWORD dwErr = GetLastError();
 708                   sv_setnv(sv, (NV)dwErr);
 709                   if (dwErr) {
 710                        PerlProc_GetOSError(sv, dwErr);
 711                   }
 712                   else
 713                        sv_setpvn(sv, "", 0);
 714                   SetLastError(dwErr);
 715              }
 716 #else
 717              {
 718                  const int saveerrno = errno;
 719                  sv_setnv(sv, (NV)errno);
 720                  sv_setpv(sv, errno ? Strerror(errno) : "");
 721                  errno = saveerrno;
 722              }
 723 #endif
 724 #endif
 725 #endif
 726 #endif
 727              SvRTRIM(sv);
 728              SvNOK_on(sv);      /* what a wonderful hack! */
 729          }
 730          else if (strEQ(remaining, "NCODING"))
 731               sv_setsv(sv, PL_encoding);
 732          break;
 733     case '\006':                /* ^F */
 734         sv_setiv(sv, (IV)PL_maxsysfd);
 735         break;
 736     case '\010':                /* ^H */
 737         sv_setiv(sv, (IV)PL_hints);
 738         break;
 739     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 740         if (PL_inplace)
 741             sv_setpv(sv, PL_inplace);
 742         else
 743             sv_setsv(sv, &PL_sv_undef);
 744         break;
 745     case '\017':                /* ^O & ^OPEN */
 746         if (nextchar == '\0') {
 747             sv_setpv(sv, PL_osname);
 748             SvTAINTED_off(sv);
 749         }
 750         else if (strEQ(remaining, "PEN")) {
 751             if (!PL_compiling.cop_io)
 752                 sv_setsv(sv, &PL_sv_undef);
 753             else {
 754                 sv_setsv(sv, PL_compiling.cop_io);
 755             }
 756         }
 757         break;
 758     case '\020':                /* ^P */
 759         sv_setiv(sv, (IV)PL_perldb);
 760         break;
 761     case '\023':                /* ^S */
 762         if (nextchar == '\0') {
 763             if (PL_lex_state != LEX_NOTPARSING)
 764                 SvOK_off(sv);
 765             else if (PL_in_eval)
 766                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 767             else
 768                 sv_setiv(sv, 0);
 769         }
 770         break;
 771     case '\024':                /* ^T */
 772         if (nextchar == '\0') {
 773 #ifdef BIG_TIME
 774             sv_setnv(sv, PL_basetime);
 775 #else
 776             sv_setiv(sv, (IV)PL_basetime);
 777 #endif
 778         }
 779         else if (strEQ(remaining, "AINT"))
 780             sv_setiv(sv, PL_tainting
 781                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 782                     : 0);
 783         break;
 784     case '\025':                /* $^UNICODE, $^UTF8LOCALE */
 785         if (strEQ(remaining, "NICODE"))
 786             sv_setuv(sv, (UV) PL_unicode);
 787         else if (strEQ(remaining, "TF8LOCALE"))
 788             sv_setuv(sv, (UV) PL_utf8locale);
 789         break;
 790     case '\027':                /* ^W  & $^WARNING_BITS */
 791         if (nextchar == '\0')
 792             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 793         else if (strEQ(remaining, "ARNING_BITS")) {
 794             if (PL_compiling.cop_warnings == pWARN_NONE) {
 795                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 796             }
 797             else if (PL_compiling.cop_warnings == pWARN_STD) {
 798                 sv_setpvn(
 799                     sv,
 800                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 801                     WARNsize
 802                 );
 803             }
 804             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 805                 /* Get the bit mask for $warnings::Bits{all}, because
 806                  * it could have been extended by warnings::register */
 807                 SV **bits_all;
 808                 HV * const bits=get_hv("warnings::Bits", FALSE);
 809                 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
 810                     sv_setsv(sv, *bits_all);
 811                 }
 812                 else {
 813                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 814                 }
 815             }
 816             else {
 817                 sv_setsv(sv, PL_compiling.cop_warnings);
 818             }
 819             SvPOK_only(sv);
 820         }
 821         break;
 822     case '1': case '2': case '3': case '4':
 823     case '5': case '6': case '7': case '8': case '9': case '&':
 824         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 825             I32 s1, t1;
 826
 827             /*
 828              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 829              * XXX Does the new way break anything?
 830              */
 831             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 832           getparen:
 833             if (paren <= (I32)rx->nparens &&
 834                 (s1 = rx->startp[paren]) != -1 &&
 835                 (t1 = rx->endp[paren]) != -1)
 836             {
 837                 i = t1 - s1;
 838                 s = rx->subbeg + s1;
 839                 if (!rx->subbeg)
 840                     break;
 841
 842               getrx:
 843                 if (i >= 0) {
 844                     int oldtainted = PL_tainted;
 845                     TAINT_NOT;
 846                     sv_setpvn(sv, s, i);
 847                     PL_tainted = oldtainted;
 848                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 849                         SvUTF8_on(sv);
 850                     else
 851                         SvUTF8_off(sv);
 852                     if (PL_tainting) {
 853                         if (RX_MATCH_TAINTED(rx)) {
 854                             MAGIC* const mg = SvMAGIC(sv);
 855                             MAGIC* mgt;
 856                             PL_tainted = 1;
 857                             SvMAGIC_set(sv, mg->mg_moremagic);
 858                             SvTAINT(sv);
 859                             if ((mgt = SvMAGIC(sv))) {
 860                                 mg->mg_moremagic = mgt;
 861                                 SvMAGIC_set(sv, mg);
 862                             }
 863                         } else
 864                             SvTAINTED_off(sv);
 865                     }
 866                     break;
 867                 }
 868             }
 869         }
 870         sv_setsv(sv,&PL_sv_undef);
 871         break;
 872     case '+':
 873         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 874             paren = rx->lastparen;
 875             if (paren)
 876                 goto getparen;
 877         }
 878         sv_setsv(sv,&PL_sv_undef);
 879         break;
 880     case '\016':                /* ^N */
 881         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 882             paren = rx->lastcloseparen;
 883             if (paren)
 884                 goto getparen;
 885         }
 886         sv_setsv(sv,&PL_sv_undef);
 887         break;
 888     case '`':
 889         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 890             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 891                 i = rx->startp[0];
 892                 goto getrx;
 893             }
 894         }
 895         sv_setsv(sv,&PL_sv_undef);
 896         break;
 897     case '\'':
 898         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 899             if (rx->subbeg && rx->endp[0] != -1) {
 900                 s = rx->subbeg + rx->endp[0];
 901                 i = rx->sublen - rx->endp[0];
 902                 goto getrx;
 903             }
 904         }
 905         sv_setsv(sv,&PL_sv_undef);
 906         break;
 907     case '.':
 908         if (GvIO(PL_last_in_gv)) {
 909             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 910         }
 911         break;
 912     case '?':
 913         {
 914             sv_setiv(sv, (IV)STATUS_CURRENT);
 915 #ifdef COMPLEX_STATUS
 916             LvTARGOFF(sv) = PL_statusvalue;
 917             LvTARGLEN(sv) = PL_statusvalue_vms;
 918 #endif
 919         }
 920         break;
 921     case '^':
 922         if (GvIOp(PL_defoutgv))
 923             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 924         if (s)
 925             sv_setpv(sv,s);
 926         else {
 927             sv_setpv(sv,GvENAME(PL_defoutgv));
 928             sv_catpv(sv,"_TOP");
 929         }
 930         break;
 931     case '~':
 932         if (GvIOp(PL_defoutgv))
 933             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 934         if (!s)
 935             s = GvENAME(PL_defoutgv);
 936         sv_setpv(sv,s);
 937         break;
 938     case '=':
 939         if (GvIOp(PL_defoutgv))
 940             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 941         break;
 942     case '-':
 943         if (GvIOp(PL_defoutgv))
 944             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 945         break;
 946     case '%':
 947         if (GvIOp(PL_defoutgv))
 948             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 949         break;
 950     case ':':
 951         break;
 952     case '/':
 953         break;
 954     case '[':
 955         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 956         break;
 957     case '|':
 958         if (GvIOp(PL_defoutgv))
 959             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 960         break;
 961     case ',':
 962         break;
 963     case '\\':
 964         if (PL_ors_sv)
 965             sv_copypv(sv, PL_ors_sv);
 966         break;
 967     case '!':
 968 #ifdef VMS
 969         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 970         sv_setpv(sv, errno ? Strerror(errno) : "");
 971 #else
 972         {
 973         const int saveerrno = errno;
 974         sv_setnv(sv, (NV)errno);
 975 #ifdef OS2
 976         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 977             sv_setpv(sv, os2error(Perl_rc));
 978         else
 979 #endif
 980         sv_setpv(sv, errno ? Strerror(errno) : "");
 981         errno = saveerrno;
 982         }
 983 #endif
 984         SvRTRIM(sv);
 985         SvNOK_on(sv);   /* what a wonderful hack! */
 986         break;
 987     case '<':
 988         sv_setiv(sv, (IV)PL_uid);
 989         break;
 990     case '>':
 991         sv_setiv(sv, (IV)PL_euid);
 992         break;
 993     case '(':
 994         sv_setiv(sv, (IV)PL_gid);
 995 #ifdef HAS_GETGROUPS
 996         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
 997 #endif
 998         goto add_groups;
 999     case ')':
1000         sv_setiv(sv, (IV)PL_egid);
1001 #ifdef HAS_GETGROUPS
1002         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1003 #endif
1004       add_groups:
1005 #ifdef HAS_GETGROUPS
1006         {
1007             Groups_t gary[NGROUPS];
1008             I32 j = getgroups(NGROUPS,gary);
1009             while (--j >= 0)
1010                 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
1011         }
1012 #endif
1013         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1014         break;
1015 #ifndef MACOS_TRADITIONAL
1016     case '0':
1017         break;
1018 #endif
1019     }
1020     return 0;
1021 }
1022
1023 int
1024 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1025 {
1026     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1027
1028     if (uf && uf->uf_val)
1029         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1030     return 0;
1031 }
1032
1033 int
1034 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1035 {
1036     dVAR;
1037     const char *s;
1038     const char *ptr;
1039     STRLEN len, klen;
1040
1041     s = SvPV_const(sv,len);
1042     ptr = MgPV_const(mg,klen);
1043     my_setenv(ptr, s);
1044
1045 #ifdef DYNAMIC_ENV_FETCH
1046      /* We just undefd an environment var.  Is a replacement */
1047      /* waiting in the wings? */
1048     if (!len) {
1049         SV **valp;
1050         if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1051             s = SvPV_const(*valp, len);
1052     }
1053 #endif
1054
1055 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1056                             /* And you'll never guess what the dog had */
1057                             /*   in its mouth... */
1058     if (PL_tainting) {
1059         MgTAINTEDDIR_off(mg);
1060 #ifdef VMS
1061         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1062             char pathbuf[256], eltbuf[256], *cp, *elt;
1063             Stat_t sbuf;
1064             int i = 0, j = 0;
1065
1066             strncpy(eltbuf, s, 255);
1067             eltbuf[255] = 0;
1068             elt = eltbuf;
1069             do {          /* DCL$PATH may be a search list */
1070                 while (1) {   /* as may dev portion of any element */
1071                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1072                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1073                              cando_by_name(S_IWUSR,0,elt) ) {
1074                             MgTAINTEDDIR_on(mg);
1075                             return 0;
1076                         }
1077                     }
1078                     if ((cp = strchr(elt, ':')) != Nullch)
1079                         *cp = '\0';
1080                     if (my_trnlnm(elt, eltbuf, j++))
1081                         elt = eltbuf;
1082                     else
1083                         break;
1084                 }
1085                 j = 0;
1086             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1087         }
1088 #endif /* VMS */
1089         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1090             const char * const strend = s + len;
1091
1092             while (s < strend) {
1093                 char tmpbuf[256];
1094                 Stat_t st;
1095                 I32 i;
1096                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1097                              s, strend, ':', &i);
1098                 s++;
1099                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1100                       || *tmpbuf != '/'
1101                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1102                     MgTAINTEDDIR_on(mg);
1103                     return 0;
1104                 }
1105             }
1106         }
1107     }
1108 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1109
1110     return 0;
1111 }
1112
1113 int
1114 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1115 {
1116     PERL_UNUSED_ARG(sv);
1117     my_setenv(MgPV_nolen_const(mg),Nullch);
1118     return 0;
1119 }
1120
1121 int
1122 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1123 {
1124     PERL_UNUSED_ARG(mg);
1125 #if defined(VMS)
1126     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1127 #else
1128     if (PL_localizing) {
1129         HE* entry;
1130         my_clearenv();
1131         hv_iterinit((HV*)sv);
1132         while ((entry = hv_iternext((HV*)sv))) {
1133             I32 keylen;
1134             my_setenv(hv_iterkey(entry, &keylen),
1135                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1136         }
1137     }
1138 #endif
1139     return 0;
1140 }
1141
1142 int
1143 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1144 {
1145     dVAR;
1146     PERL_UNUSED_ARG(sv);
1147     PERL_UNUSED_ARG(mg);
1148 #if defined(VMS)
1149     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1150 #else
1151     my_clearenv();
1152 #endif
1153     return 0;
1154 }
1155
1156 #ifndef PERL_MICRO
1157 #ifdef HAS_SIGPROCMASK
1158 static void
1159 restore_sigmask(pTHX_ SV *save_sv)
1160 {
1161     const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1162     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1163 }
1164 #endif
1165 int
1166 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1167 {
1168     /* Are we fetching a signal entry? */
1169     const I32 i = whichsig(MgPV_nolen_const(mg));
1170     if (i > 0) {
1171         if(PL_psig_ptr[i])
1172             sv_setsv(sv,PL_psig_ptr[i]);
1173         else {
1174             Sighandler_t sigstate;
1175             sigstate = rsignal_state(i);
1176 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1177             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1178 #endif
1179 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1180             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1181 #endif
1182             /* cache state so we don't fetch it again */
1183             if(sigstate == (Sighandler_t) SIG_IGN)
1184                 sv_setpv(sv,"IGNORE");
1185             else
1186                 sv_setsv(sv,&PL_sv_undef);
1187             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1188             SvTEMP_off(sv);
1189         }
1190     }
1191     return 0;
1192 }
1193 int
1194 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1195 {
1196     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1197      * refactoring might be in order.
1198      */
1199     dVAR;
1200     register const char * const s = MgPV_nolen_const(mg);
1201     PERL_UNUSED_ARG(sv);
1202     if (*s == '_') {
1203         SV** svp = 0;
1204         if (strEQ(s,"__DIE__"))
1205             svp = &PL_diehook;
1206         else if (strEQ(s,"__WARN__"))
1207             svp = &PL_warnhook;
1208         else
1209             Perl_croak(aTHX_ "No such hook: %s", s);
1210         if (svp && *svp) {
1211             SV * const to_dec = *svp;
1212             *svp = 0;
1213             SvREFCNT_dec(to_dec);
1214         }
1215     }
1216     else {
1217         /* Are we clearing a signal entry? */
1218         const I32 i = whichsig(s);
1219         if (i > 0) {
1220 #ifdef HAS_SIGPROCMASK
1221             sigset_t set, save;
1222             SV* save_sv;
1223             /* Avoid having the signal arrive at a bad time, if possible. */
1224             sigemptyset(&set);
1225             sigaddset(&set,i);
1226             sigprocmask(SIG_BLOCK, &set, &save);
1227             ENTER;
1228             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1229             SAVEFREESV(save_sv);
1230             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1231 #endif
1232             PERL_ASYNC_CHECK();
1233 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1234             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1235 #endif
1236 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1237             PL_sig_defaulting[i] = 1;
1238             (void)rsignal(i, PL_csighandlerp);
1239 #else
1240             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1241 #endif
1242             if(PL_psig_name[i]) {
1243                 SvREFCNT_dec(PL_psig_name[i]);
1244                 PL_psig_name[i]=0;
1245             }
1246             if(PL_psig_ptr[i]) {
1247                 SV *to_dec=PL_psig_ptr[i];
1248                 PL_psig_ptr[i]=0;
1249                 LEAVE;
1250                 SvREFCNT_dec(to_dec);
1251             }
1252             else
1253                 LEAVE;
1254         }
1255     }
1256     return 0;
1257 }
1258
1259 static void
1260 S_raise_signal(pTHX_ int sig)
1261 {
1262     /* Set a flag to say this signal is pending */
1263     PL_psig_pend[sig]++;
1264     /* And one to say _a_ signal is pending */
1265     PL_sig_pending = 1;
1266 }
1267
1268 Signal_t
1269 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1270 Perl_csighandler(int sig, ...)
1271 #else
1272 Perl_csighandler(int sig)
1273 #endif
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, (Sighandler_t) 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, (Sighandler_t) 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     /* Not sure why the av can get freed ahead of its sv, but somehow it does
2045        in ext/B/t/bytecode.t test 15 (involving print <DATA>)  */
2046     if (svp && !SvIS_FREED(av)) {
2047         SV *const *const last = svp + AvFILLp(av);
2048
2049         while (svp <= last) {
2050             if (*svp) {
2051                 SV *const referrer = *svp;
2052                 if (SvWEAKREF(referrer)) {
2053                     /* XXX Should we check that it hasn't changed? */
2054                     SvRV_set(referrer, 0);
2055                     SvOK_off(referrer);
2056                     SvWEAKREF_off(referrer);
2057                 } else if (SvTYPE(referrer) == SVt_PVGV ||
2058                            SvTYPE(referrer) == SVt_PVLV) {
2059                     /* You lookin' at me?  */
2060                     assert(GvSTASH(referrer));
2061                     assert(GvSTASH(referrer) == (HV*)sv);
2062                     GvSTASH(referrer) = 0;
2063                 } else {
2064                     Perl_croak(aTHX_
2065                                "panic: magic_killbackrefs (flags=%"UVxf")",
2066                                (UV)SvFLAGS(referrer));
2067                 }
2068
2069                 *svp = Nullsv;
2070             }
2071             svp++;
2072         }
2073     }
2074     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2075     return 0;
2076 }
2077
2078 int
2079 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2080 {
2081     mg->mg_len = -1;
2082     SvSCREAM_off(sv);
2083     return 0;
2084 }
2085
2086 int
2087 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2088 {
2089     PERL_UNUSED_ARG(mg);
2090     sv_unmagic(sv, PERL_MAGIC_bm);
2091     SvVALID_off(sv);
2092     return 0;
2093 }
2094
2095 int
2096 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2097 {
2098     PERL_UNUSED_ARG(mg);
2099     sv_unmagic(sv, PERL_MAGIC_fm);
2100     SvCOMPILED_off(sv);
2101     return 0;
2102 }
2103
2104 int
2105 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2106 {
2107     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2108
2109     if (uf && uf->uf_set)
2110         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2111     return 0;
2112 }
2113
2114 int
2115 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2116 {
2117     PERL_UNUSED_ARG(mg);
2118     sv_unmagic(sv, PERL_MAGIC_qr);
2119     return 0;
2120 }
2121
2122 int
2123 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2124 {
2125     regexp * const re = (regexp *)mg->mg_obj;
2126     PERL_UNUSED_ARG(sv);
2127
2128     ReREFCNT_dec(re);
2129     return 0;
2130 }
2131
2132 #ifdef USE_LOCALE_COLLATE
2133 int
2134 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2135 {
2136     /*
2137      * RenE<eacute> Descartes said "I think not."
2138      * and vanished with a faint plop.
2139      */
2140     PERL_UNUSED_ARG(sv);
2141     if (mg->mg_ptr) {
2142         Safefree(mg->mg_ptr);
2143         mg->mg_ptr = NULL;
2144         mg->mg_len = -1;
2145     }
2146     return 0;
2147 }
2148 #endif /* USE_LOCALE_COLLATE */
2149
2150 /* Just clear the UTF-8 cache data. */
2151 int
2152 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2153 {
2154     PERL_UNUSED_ARG(sv);
2155     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2156     mg->mg_ptr = 0;
2157     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2158     return 0;
2159 }
2160
2161 int
2162 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2163 {
2164     register const char *s;
2165     I32 i;
2166     STRLEN len;
2167     switch (*mg->mg_ptr) {
2168     case '\001':        /* ^A */
2169         sv_setsv(PL_bodytarget, sv);
2170         break;
2171     case '\003':        /* ^C */
2172         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2173         break;
2174
2175     case '\004':        /* ^D */
2176 #ifdef DEBUGGING
2177         s = SvPV_nolen_const(sv);
2178         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2179         DEBUG_x(dump_all());
2180 #else
2181         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2182 #endif
2183         break;
2184     case '\005':  /* ^E */
2185         if (*(mg->mg_ptr+1) == '\0') {
2186 #ifdef MACOS_TRADITIONAL
2187             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2188 #else
2189 #  ifdef VMS
2190             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2191 #  else
2192 #    ifdef WIN32
2193             SetLastError( SvIV(sv) );
2194 #    else
2195 #      ifdef OS2
2196             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2197 #      else
2198             /* will anyone ever use this? */
2199             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2200 #      endif
2201 #    endif
2202 #  endif
2203 #endif
2204         }
2205         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2206             if (PL_encoding)
2207                 SvREFCNT_dec(PL_encoding);
2208             if (SvOK(sv) || SvGMAGICAL(sv)) {
2209                 PL_encoding = newSVsv(sv);
2210             }
2211             else {
2212                 PL_encoding = Nullsv;
2213             }
2214         }
2215         break;
2216     case '\006':        /* ^F */
2217         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2218         break;
2219     case '\010':        /* ^H */
2220         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2221         break;
2222     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2223         Safefree(PL_inplace);
2224         PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2225         break;
2226     case '\017':        /* ^O */
2227         if (*(mg->mg_ptr+1) == '\0') {
2228             Safefree(PL_osname);
2229             PL_osname = Nullch;
2230             if (SvOK(sv)) {
2231                 TAINT_PROPER("assigning to $^O");
2232                 PL_osname = savesvpv(sv);
2233             }
2234         }
2235         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2236             if (!PL_compiling.cop_io)
2237                 PL_compiling.cop_io = newSVsv(sv);
2238             else
2239                 sv_setsv(PL_compiling.cop_io,sv);
2240         }
2241         break;
2242     case '\020':        /* ^P */
2243         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2244         if (PL_perldb && !PL_DBsingle)
2245             init_debugger();
2246         break;
2247     case '\024':        /* ^T */
2248 #ifdef BIG_TIME
2249         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2250 #else
2251         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2252 #endif
2253         break;
2254     case '\027':        /* ^W & $^WARNING_BITS */
2255         if (*(mg->mg_ptr+1) == '\0') {
2256             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2257                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2258                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2259                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2260             }
2261         }
2262         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2263             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2264                 if (!SvPOK(sv) && PL_localizing) {
2265                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2266                     PL_compiling.cop_warnings = pWARN_NONE;
2267                     break;
2268                 }
2269                 {
2270                     STRLEN len, i;
2271                     int accumulate = 0 ;
2272                     int any_fatals = 0 ;
2273                     const char * const ptr = SvPV_const(sv, len) ;
2274                     for (i = 0 ; i < len ; ++i) {
2275                         accumulate |= ptr[i] ;
2276                         any_fatals |= (ptr[i] & 0xAA) ;
2277                     }
2278                     if (!accumulate)
2279                         PL_compiling.cop_warnings = pWARN_NONE;
2280                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2281                         PL_compiling.cop_warnings = pWARN_ALL;
2282                         PL_dowarn |= G_WARN_ONCE ;
2283                     }
2284                     else {
2285                         if (specialWARN(PL_compiling.cop_warnings))
2286                             PL_compiling.cop_warnings = newSVsv(sv) ;
2287                         else
2288                             sv_setsv(PL_compiling.cop_warnings, sv);
2289                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2290                             PL_dowarn |= G_WARN_ONCE ;
2291                     }
2292
2293                 }
2294             }
2295         }
2296         break;
2297     case '.':
2298         if (PL_localizing) {
2299             if (PL_localizing == 1)
2300                 SAVESPTR(PL_last_in_gv);
2301         }
2302         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2303             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2304         break;
2305     case '^':
2306         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2307         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2308         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2309         break;
2310     case '~':
2311         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2312         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2313         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2314         break;
2315     case '=':
2316         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2317         break;
2318     case '-':
2319         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2320         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2321             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2322         break;
2323     case '%':
2324         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2325         break;
2326     case '|':
2327         {
2328             IO * const io = GvIOp(PL_defoutgv);
2329             if(!io)
2330               break;
2331             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2332                 IoFLAGS(io) &= ~IOf_FLUSH;
2333             else {
2334                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2335                     PerlIO *ofp = IoOFP(io);
2336                     if (ofp)
2337                         (void)PerlIO_flush(ofp);
2338                     IoFLAGS(io) |= IOf_FLUSH;
2339                 }
2340             }
2341         }
2342         break;
2343     case '/':
2344         SvREFCNT_dec(PL_rs);
2345         PL_rs = newSVsv(sv);
2346         break;
2347     case '\\':
2348         if (PL_ors_sv)
2349             SvREFCNT_dec(PL_ors_sv);
2350         if (SvOK(sv) || SvGMAGICAL(sv)) {
2351             PL_ors_sv = newSVsv(sv);
2352         }
2353         else {
2354             PL_ors_sv = Nullsv;
2355         }
2356         break;
2357     case ',':
2358         if (PL_ofs_sv)
2359             SvREFCNT_dec(PL_ofs_sv);
2360         if (SvOK(sv) || SvGMAGICAL(sv)) {
2361             PL_ofs_sv = newSVsv(sv);
2362         }
2363         else {
2364             PL_ofs_sv = Nullsv;
2365         }
2366         break;
2367     case '[':
2368         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2369         break;
2370     case '?':
2371 #ifdef COMPLEX_STATUS
2372         if (PL_localizing == 2) {
2373             PL_statusvalue = LvTARGOFF(sv);
2374             PL_statusvalue_vms = LvTARGLEN(sv);
2375         }
2376         else
2377 #endif
2378 #ifdef VMSISH_STATUS
2379         if (VMSISH_STATUS)
2380             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2381         else
2382 #endif
2383             STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2384         break;
2385     case '!':
2386         {
2387 #ifdef VMS
2388 #   define PERL_VMS_BANG vaxc$errno
2389 #else
2390 #   define PERL_VMS_BANG 0
2391 #endif
2392         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2393                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2394         }
2395         break;
2396     case '<':
2397         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2398         if (PL_delaymagic) {
2399             PL_delaymagic |= DM_RUID;
2400             break;                              /* don't do magic till later */
2401         }
2402 #ifdef HAS_SETRUID
2403         (void)setruid((Uid_t)PL_uid);
2404 #else
2405 #ifdef HAS_SETREUID
2406         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2407 #else
2408 #ifdef HAS_SETRESUID
2409       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2410 #else
2411         if (PL_uid == PL_euid) {                /* special case $< = $> */
2412 #ifdef PERL_DARWIN
2413             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2414             if (PL_uid != 0 && PerlProc_getuid() == 0)
2415                 (void)PerlProc_setuid(0);
2416 #endif
2417             (void)PerlProc_setuid(PL_uid);
2418         } else {
2419             PL_uid = PerlProc_getuid();
2420             Perl_croak(aTHX_ "setruid() not implemented");
2421         }
2422 #endif
2423 #endif
2424 #endif
2425         PL_uid = PerlProc_getuid();
2426         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2427         break;
2428     case '>':
2429         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2430         if (PL_delaymagic) {
2431             PL_delaymagic |= DM_EUID;
2432             break;                              /* don't do magic till later */
2433         }
2434 #ifdef HAS_SETEUID
2435         (void)seteuid((Uid_t)PL_euid);
2436 #else
2437 #ifdef HAS_SETREUID
2438         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2439 #else
2440 #ifdef HAS_SETRESUID
2441         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2442 #else
2443         if (PL_euid == PL_uid)          /* special case $> = $< */
2444             PerlProc_setuid(PL_euid);
2445         else {
2446             PL_euid = PerlProc_geteuid();
2447             Perl_croak(aTHX_ "seteuid() not implemented");
2448         }
2449 #endif
2450 #endif
2451 #endif
2452         PL_euid = PerlProc_geteuid();
2453         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2454         break;
2455     case '(':
2456         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2457         if (PL_delaymagic) {
2458             PL_delaymagic |= DM_RGID;
2459             break;                              /* don't do magic till later */
2460         }
2461 #ifdef HAS_SETRGID
2462         (void)setrgid((Gid_t)PL_gid);
2463 #else
2464 #ifdef HAS_SETREGID
2465         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2466 #else
2467 #ifdef HAS_SETRESGID
2468       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2469 #else
2470         if (PL_gid == PL_egid)                  /* special case $( = $) */
2471             (void)PerlProc_setgid(PL_gid);
2472         else {
2473             PL_gid = PerlProc_getgid();
2474             Perl_croak(aTHX_ "setrgid() not implemented");
2475         }
2476 #endif
2477 #endif
2478 #endif
2479         PL_gid = PerlProc_getgid();
2480         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2481         break;
2482     case ')':
2483 #ifdef HAS_SETGROUPS
2484         {
2485             const char *p = SvPV_const(sv, len);
2486             Groups_t gary[NGROUPS];
2487
2488             while (isSPACE(*p))
2489                 ++p;
2490             PL_egid = Atol(p);
2491             for (i = 0; i < NGROUPS; ++i) {
2492                 while (*p && !isSPACE(*p))
2493                     ++p;
2494                 while (isSPACE(*p))
2495                     ++p;
2496                 if (!*p)
2497                     break;
2498                 gary[i] = Atol(p);
2499             }
2500             if (i)
2501                 (void)setgroups(i, gary);
2502         }
2503 #else  /* HAS_SETGROUPS */
2504         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2505 #endif /* HAS_SETGROUPS */
2506         if (PL_delaymagic) {
2507             PL_delaymagic |= DM_EGID;
2508             break;                              /* don't do magic till later */
2509         }
2510 #ifdef HAS_SETEGID
2511         (void)setegid((Gid_t)PL_egid);
2512 #else
2513 #ifdef HAS_SETREGID
2514         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2515 #else
2516 #ifdef HAS_SETRESGID
2517         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2518 #else
2519         if (PL_egid == PL_gid)                  /* special case $) = $( */
2520             (void)PerlProc_setgid(PL_egid);
2521         else {
2522             PL_egid = PerlProc_getegid();
2523             Perl_croak(aTHX_ "setegid() not implemented");
2524         }
2525 #endif
2526 #endif
2527 #endif
2528         PL_egid = PerlProc_getegid();
2529         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2530         break;
2531     case ':':
2532         PL_chopset = SvPV_force(sv,len);
2533         break;
2534 #ifndef MACOS_TRADITIONAL
2535     case '0':
2536         LOCK_DOLLARZERO_MUTEX;
2537 #ifdef HAS_SETPROCTITLE
2538         /* The BSDs don't show the argv[] in ps(1) output, they
2539          * show a string from the process struct and provide
2540          * the setproctitle() routine to manipulate that. */
2541         {
2542             s = SvPV_const(sv, len);
2543 #   if __FreeBSD_version > 410001
2544             /* The leading "-" removes the "perl: " prefix,
2545              * but not the "(perl) suffix from the ps(1)
2546              * output, because that's what ps(1) shows if the
2547              * argv[] is modified. */
2548             setproctitle("-%s", s);
2549 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2550             /* This doesn't really work if you assume that
2551              * $0 = 'foobar'; will wipe out 'perl' from the $0
2552              * because in ps(1) output the result will be like
2553              * sprintf("perl: %s (perl)", s)
2554              * I guess this is a security feature:
2555              * one (a user process) cannot get rid of the original name.
2556              * --jhi */
2557             setproctitle("%s", s);
2558 #   endif
2559         }
2560 #endif
2561 #if defined(__hpux) && defined(PSTAT_SETCMD)
2562         {
2563              union pstun un;
2564              s = SvPV_const(sv, len);
2565              un.pst_command = (char *)s;
2566              pstat(PSTAT_SETCMD, un, len, 0, 0);
2567         }
2568 #endif
2569         /* PL_origalen is set in perl_parse(). */
2570         s = SvPV_force(sv,len);
2571         if (len >= (STRLEN)PL_origalen-1) {
2572             /* Longer than original, will be truncated. We assume that
2573              * PL_origalen bytes are available. */
2574             Copy(s, PL_origargv[0], PL_origalen-1, char);
2575         }
2576         else {
2577             /* Shorter than original, will be padded. */
2578             Copy(s, PL_origargv[0], len, char);
2579             PL_origargv[0][len] = 0;
2580             memset(PL_origargv[0] + len + 1,
2581                    /* Is the space counterintuitive?  Yes.
2582                     * (You were expecting \0?)
2583                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2584                     * --jhi */
2585                    (int)' ',
2586                    PL_origalen - len - 1);
2587         }
2588         PL_origargv[0][PL_origalen-1] = 0;
2589         for (i = 1; i < PL_origargc; i++)
2590             PL_origargv[i] = 0;
2591         UNLOCK_DOLLARZERO_MUTEX;
2592         break;
2593 #endif
2594     }
2595     return 0;
2596 }
2597
2598 I32
2599 Perl_whichsig(pTHX_ const char *sig)
2600 {
2601     register char* const* sigv;
2602
2603     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2604         if (strEQ(sig,*sigv))
2605             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2606 #ifdef SIGCLD
2607     if (strEQ(sig,"CHLD"))
2608         return SIGCLD;
2609 #endif
2610 #ifdef SIGCHLD
2611     if (strEQ(sig,"CLD"))
2612         return SIGCHLD;
2613 #endif
2614     return -1;
2615 }
2616
2617 Signal_t
2618 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2619 Perl_sighandler(int sig, ...)
2620 #else
2621 Perl_sighandler(int sig)
2622 #endif
2623 {
2624 #ifdef PERL_GET_SIG_CONTEXT
2625     dTHXa(PERL_GET_SIG_CONTEXT);
2626 #else
2627     dTHX;
2628 #endif
2629     dSP;
2630     GV *gv = Nullgv;
2631     SV *sv = Nullsv;
2632     SV * const tSv = PL_Sv;
2633     CV *cv = Nullcv;
2634     OP *myop = PL_op;
2635     U32 flags = 0;
2636     XPV * const tXpv = PL_Xpv;
2637
2638     if (PL_savestack_ix + 15 <= PL_savestack_max)
2639         flags |= 1;
2640     if (PL_markstack_ptr < PL_markstack_max - 2)
2641         flags |= 4;
2642     if (PL_scopestack_ix < PL_scopestack_max - 3)
2643         flags |= 16;
2644
2645     if (!PL_psig_ptr[sig]) {
2646                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2647                                  PL_sig_name[sig]);
2648                 exit(sig);
2649         }
2650
2651     /* Max number of items pushed there is 3*n or 4. We cannot fix
2652        infinity, so we fix 4 (in fact 5): */
2653     if (flags & 1) {
2654         PL_savestack_ix += 5;           /* Protect save in progress. */
2655         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2656     }
2657     if (flags & 4)
2658         PL_markstack_ptr++;             /* Protect mark. */
2659     if (flags & 16)
2660         PL_scopestack_ix += 1;
2661     /* sv_2cv is too complicated, try a simpler variant first: */
2662     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2663         || SvTYPE(cv) != SVt_PVCV) {
2664         HV *st;
2665         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2666     }
2667
2668     if (!cv || !CvROOT(cv)) {
2669         if (ckWARN(WARN_SIGNAL))
2670             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2671                 PL_sig_name[sig], (gv ? GvENAME(gv)
2672                                 : ((cv && CvGV(cv))
2673                                    ? GvENAME(CvGV(cv))
2674                                    : "__ANON__")));
2675         goto cleanup;
2676     }
2677
2678     if(PL_psig_name[sig]) {
2679         sv = SvREFCNT_inc(PL_psig_name[sig]);
2680         flags |= 64;
2681 #if !defined(PERL_IMPLICIT_CONTEXT)
2682         PL_sig_sv = sv;
2683 #endif
2684     } else {
2685         sv = sv_newmortal();
2686         sv_setpv(sv,PL_sig_name[sig]);
2687     }
2688
2689     PUSHSTACKi(PERLSI_SIGNAL);
2690     PUSHMARK(SP);
2691     PUSHs(sv);
2692 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2693     {
2694          struct sigaction oact;
2695
2696          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2697               siginfo_t *sip;
2698               va_list args;
2699
2700               va_start(args, sig);
2701               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2702               if (sip) {
2703                    HV *sih = newHV();
2704                    SV *rv  = newRV_noinc((SV*)sih);
2705                    /* The siginfo fields signo, code, errno, pid, uid,
2706                     * addr, status, and band are defined by POSIX/SUSv3. */
2707                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2708                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2709 #if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
2710                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2711                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2712                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2713                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2714                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2715                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2716 #endif
2717                    EXTEND(SP, 2);
2718                    PUSHs((SV*)rv);
2719                    PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2720               }
2721
2722               va_end(args);
2723          }
2724     }
2725 #endif
2726     PUTBACK;
2727
2728     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2729
2730     POPSTACK;
2731     if (SvTRUE(ERRSV)) {
2732 #ifndef PERL_MICRO
2733 #ifdef HAS_SIGPROCMASK
2734         /* Handler "died", for example to get out of a restart-able read().
2735          * Before we re-do that on its behalf re-enable the signal which was
2736          * blocked by the system when we entered.
2737          */
2738         sigset_t set;
2739         sigemptyset(&set);
2740         sigaddset(&set,sig);
2741         sigprocmask(SIG_UNBLOCK, &set, NULL);
2742 #else
2743         /* Not clear if this will work */
2744         (void)rsignal(sig, SIG_IGN);
2745         (void)rsignal(sig, PL_csighandlerp);
2746 #endif
2747 #endif /* !PERL_MICRO */
2748         Perl_die(aTHX_ Nullch);
2749     }
2750 cleanup:
2751     if (flags & 1)
2752         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2753     if (flags & 4)
2754         PL_markstack_ptr--;
2755     if (flags & 16)
2756         PL_scopestack_ix -= 1;
2757     if (flags & 64)
2758         SvREFCNT_dec(sv);
2759     PL_op = myop;                       /* Apparently not needed... */
2760
2761     PL_Sv = tSv;                        /* Restore global temporaries. */
2762     PL_Xpv = tXpv;
2763     return;
2764 }
2765
2766
2767 static void
2768 S_restore_magic(pTHX_ const void *p)
2769 {
2770     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2771     SV* const sv = mgs->mgs_sv;
2772
2773     if (!sv)
2774         return;
2775
2776     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2777     {
2778 #ifdef PERL_OLD_COPY_ON_WRITE
2779         /* While magic was saved (and off) sv_setsv may well have seen
2780            this SV as a prime candidate for COW.  */
2781         if (SvIsCOW(sv))
2782             sv_force_normal_flags(sv, 0);
2783 #endif
2784
2785         if (mgs->mgs_flags)
2786             SvFLAGS(sv) |= mgs->mgs_flags;
2787         else
2788             mg_magical(sv);
2789         if (SvGMAGICAL(sv)) {
2790             /* downgrade public flags to private,
2791                and discard any other private flags */
2792
2793             U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2794             if (public) {
2795                 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2796                 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2797             }
2798         }
2799     }
2800
2801     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2802
2803     /* If we're still on top of the stack, pop us off.  (That condition
2804      * will be satisfied if restore_magic was called explicitly, but *not*
2805      * if it's being called via leave_scope.)
2806      * The reason for doing this is that otherwise, things like sv_2cv()
2807      * may leave alloc gunk on the savestack, and some code
2808      * (e.g. sighandler) doesn't expect that...
2809      */
2810     if (PL_savestack_ix == mgs->mgs_ss_ix)
2811     {
2812         I32 popval = SSPOPINT;
2813         assert(popval == SAVEt_DESTRUCTOR_X);
2814         PL_savestack_ix -= 2;
2815         popval = SSPOPINT;
2816         assert(popval == SAVEt_ALLOC);
2817         popval = SSPOPINT;
2818         PL_savestack_ix -= popval;
2819     }
2820
2821 }
2822
2823 static void
2824 S_unwind_handler_stack(pTHX_ const void *p)
2825 {
2826     dVAR;
2827     const U32 flags = *(const U32*)p;
2828
2829     if (flags & 1)
2830         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2831     /* cxstack_ix-- Not needed, die already unwound it. */
2832 #if !defined(PERL_IMPLICIT_CONTEXT)
2833     if (flags & 64)
2834         SvREFCNT_dec(PL_sig_sv);
2835 #endif
2836 }
2837
2838 /*
2839  * Local variables:
2840  * c-indentation-style: bsd
2841  * c-basic-offset: 4
2842  * indent-tabs-mode: t
2843  * End:
2844  *
2845  * ex: set ts=8 sts=4 sw=4 noet:
2846  */