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 #if defined(VMS)
1125     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1126 #else
1127     if (PL_localizing) {
1128         HE* entry;
1129         my_clearenv();
1130         hv_iterinit((HV*)sv);
1131         while ((entry = hv_iternext((HV*)sv))) {
1132             I32 keylen;
1133             my_setenv(hv_iterkey(entry, &keylen),
1134                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1135         }
1136     }
1137 #endif
1138     return 0;
1139 }
1140
1141 int
1142 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1143 {
1144     dVAR;
1145     PERL_UNUSED_ARG(sv);
1146     PERL_UNUSED_ARG(mg);
1147 #if defined(VMS)
1148     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1149 #else
1150     my_clearenv();
1151 #endif
1152     return 0;
1153 }
1154
1155 #ifndef PERL_MICRO
1156 #ifdef HAS_SIGPROCMASK
1157 static void
1158 restore_sigmask(pTHX_ SV *save_sv)
1159 {
1160     const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1161     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1162 }
1163 #endif
1164 int
1165 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1166 {
1167     /* Are we fetching a signal entry? */
1168     const I32 i = whichsig(MgPV_nolen_const(mg));
1169     if (i > 0) {
1170         if(PL_psig_ptr[i])
1171             sv_setsv(sv,PL_psig_ptr[i]);
1172         else {
1173             Sighandler_t sigstate;
1174             sigstate = rsignal_state(i);
1175 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1176             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1177 #endif
1178 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1179             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1180 #endif
1181             /* cache state so we don't fetch it again */
1182             if(sigstate == (Sighandler_t) SIG_IGN)
1183                 sv_setpv(sv,"IGNORE");
1184             else
1185                 sv_setsv(sv,&PL_sv_undef);
1186             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1187             SvTEMP_off(sv);
1188         }
1189     }
1190     return 0;
1191 }
1192 int
1193 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1194 {
1195     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1196      * refactoring might be in order.
1197      */
1198     dVAR;
1199     register const char * const s = MgPV_nolen_const(mg);
1200     PERL_UNUSED_ARG(sv);
1201     if (*s == '_') {
1202         SV** svp = 0;
1203         if (strEQ(s,"__DIE__"))
1204             svp = &PL_diehook;
1205         else if (strEQ(s,"__WARN__"))
1206             svp = &PL_warnhook;
1207         else
1208             Perl_croak(aTHX_ "No such hook: %s", s);
1209         if (svp && *svp) {
1210             SV * const to_dec = *svp;
1211             *svp = 0;
1212             SvREFCNT_dec(to_dec);
1213         }
1214     }
1215     else {
1216         /* Are we clearing a signal entry? */
1217         const I32 i = whichsig(s);
1218         if (i > 0) {
1219 #ifdef HAS_SIGPROCMASK
1220             sigset_t set, save;
1221             SV* save_sv;
1222             /* Avoid having the signal arrive at a bad time, if possible. */
1223             sigemptyset(&set);
1224             sigaddset(&set,i);
1225             sigprocmask(SIG_BLOCK, &set, &save);
1226             ENTER;
1227             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1228             SAVEFREESV(save_sv);
1229             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1230 #endif
1231             PERL_ASYNC_CHECK();
1232 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1233             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1234 #endif
1235 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1236             PL_sig_defaulting[i] = 1;
1237             (void)rsignal(i, PL_csighandlerp);
1238 #else
1239             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1240 #endif
1241             if(PL_psig_name[i]) {
1242                 SvREFCNT_dec(PL_psig_name[i]);
1243                 PL_psig_name[i]=0;
1244             }
1245             if(PL_psig_ptr[i]) {
1246                 SV *to_dec=PL_psig_ptr[i];
1247                 PL_psig_ptr[i]=0;
1248                 LEAVE;
1249                 SvREFCNT_dec(to_dec);
1250             }
1251             else
1252                 LEAVE;
1253         }
1254     }
1255     return 0;
1256 }
1257
1258 static void
1259 S_raise_signal(pTHX_ int sig)
1260 {
1261     /* Set a flag to say this signal is pending */
1262     PL_psig_pend[sig]++;
1263     /* And one to say _a_ signal is pending */
1264     PL_sig_pending = 1;
1265 }
1266
1267 Signal_t
1268 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1269 Perl_csighandler(int sig, ...)
1270 #else
1271 Perl_csighandler(int sig)
1272 #endif
1273 {
1274 #ifdef PERL_GET_SIG_CONTEXT
1275     dTHXa(PERL_GET_SIG_CONTEXT);
1276 #else
1277     dTHX;
1278 #endif
1279 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1280     (void) rsignal(sig, PL_csighandlerp);
1281     if (PL_sig_ignoring[sig]) return;
1282 #endif
1283 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1284     if (PL_sig_defaulting[sig])
1285 #ifdef KILL_BY_SIGPRC
1286             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1287 #else
1288             exit(1);
1289 #endif
1290 #endif
1291    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1292         /* Call the perl level handler now--
1293          * with risk we may be in malloc() etc. */
1294         (*PL_sighandlerp)(sig);
1295    else
1296         S_raise_signal(aTHX_ sig);
1297 }
1298
1299 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1300 void
1301 Perl_csighandler_init(void)
1302 {
1303     int sig;
1304     if (PL_sig_handlers_initted) return;
1305
1306     for (sig = 1; sig < SIG_SIZE; sig++) {
1307 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1308         dTHX;
1309         PL_sig_defaulting[sig] = 1;
1310         (void) rsignal(sig, PL_csighandlerp);
1311 #endif
1312 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1313         PL_sig_ignoring[sig] = 0;
1314 #endif
1315     }
1316     PL_sig_handlers_initted = 1;
1317 }
1318 #endif
1319
1320 void
1321 Perl_despatch_signals(pTHX)
1322 {
1323     int sig;
1324     PL_sig_pending = 0;
1325     for (sig = 1; sig < SIG_SIZE; sig++) {
1326         if (PL_psig_pend[sig]) {
1327             PERL_BLOCKSIG_ADD(set, sig);
1328             PL_psig_pend[sig] = 0;
1329             PERL_BLOCKSIG_BLOCK(set);
1330             (*PL_sighandlerp)(sig);
1331             PERL_BLOCKSIG_UNBLOCK(set);
1332         }
1333     }
1334 }
1335
1336 int
1337 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1338 {
1339     dVAR;
1340     I32 i;
1341     SV** svp = 0;
1342     /* Need to be careful with SvREFCNT_dec(), because that can have side
1343      * effects (due to closures). We must make sure that the new disposition
1344      * is in place before it is called.
1345      */
1346     SV* to_dec = 0;
1347     STRLEN len;
1348 #ifdef HAS_SIGPROCMASK
1349     sigset_t set, save;
1350     SV* save_sv;
1351 #endif
1352
1353     register const char *s = MgPV_const(mg,len);
1354     if (*s == '_') {
1355         if (strEQ(s,"__DIE__"))
1356             svp = &PL_diehook;
1357         else if (strEQ(s,"__WARN__"))
1358             svp = &PL_warnhook;
1359         else
1360             Perl_croak(aTHX_ "No such hook: %s", s);
1361         i = 0;
1362         if (*svp) {
1363             to_dec = *svp;
1364             *svp = 0;
1365         }
1366     }
1367     else {
1368         i = whichsig(s);        /* ...no, a brick */
1369         if (i <= 0) {
1370             if (ckWARN(WARN_SIGNAL))
1371                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1372             return 0;
1373         }
1374 #ifdef HAS_SIGPROCMASK
1375         /* Avoid having the signal arrive at a bad time, if possible. */
1376         sigemptyset(&set);
1377         sigaddset(&set,i);
1378         sigprocmask(SIG_BLOCK, &set, &save);
1379         ENTER;
1380         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1381         SAVEFREESV(save_sv);
1382         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1383 #endif
1384         PERL_ASYNC_CHECK();
1385 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1386         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1387 #endif
1388 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1389         PL_sig_ignoring[i] = 0;
1390 #endif
1391 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1392         PL_sig_defaulting[i] = 0;
1393 #endif
1394         SvREFCNT_dec(PL_psig_name[i]);
1395         to_dec = PL_psig_ptr[i];
1396         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1397         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1398         PL_psig_name[i] = newSVpvn(s, len);
1399         SvREADONLY_on(PL_psig_name[i]);
1400     }
1401     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1402         if (i) {
1403             (void)rsignal(i, PL_csighandlerp);
1404 #ifdef HAS_SIGPROCMASK
1405             LEAVE;
1406 #endif
1407         }
1408         else
1409             *svp = SvREFCNT_inc(sv);
1410         if(to_dec)
1411             SvREFCNT_dec(to_dec);
1412         return 0;
1413     }
1414     s = SvPV_force(sv,len);
1415     if (strEQ(s,"IGNORE")) {
1416         if (i) {
1417 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1418             PL_sig_ignoring[i] = 1;
1419             (void)rsignal(i, PL_csighandlerp);
1420 #else
1421             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1422 #endif
1423         }
1424     }
1425     else if (strEQ(s,"DEFAULT") || !*s) {
1426         if (i)
1427 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1428           {
1429             PL_sig_defaulting[i] = 1;
1430             (void)rsignal(i, PL_csighandlerp);
1431           }
1432 #else
1433             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1434 #endif
1435     }
1436     else {
1437         /*
1438          * We should warn if HINT_STRICT_REFS, but without
1439          * access to a known hint bit in a known OP, we can't
1440          * tell whether HINT_STRICT_REFS is in force or not.
1441          */
1442         if (!strchr(s,':') && !strchr(s,'\''))
1443             sv_insert(sv, 0, 0, "main::", 6);
1444         if (i)
1445             (void)rsignal(i, PL_csighandlerp);
1446         else
1447             *svp = SvREFCNT_inc(sv);
1448     }
1449 #ifdef HAS_SIGPROCMASK
1450     if(i)
1451         LEAVE;
1452 #endif
1453     if(to_dec)
1454         SvREFCNT_dec(to_dec);
1455     return 0;
1456 }
1457 #endif /* !PERL_MICRO */
1458
1459 int
1460 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1461 {
1462     PERL_UNUSED_ARG(sv);
1463     PERL_UNUSED_ARG(mg);
1464     PL_sub_generation++;
1465     return 0;
1466 }
1467
1468 int
1469 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1470 {
1471     PERL_UNUSED_ARG(sv);
1472     PERL_UNUSED_ARG(mg);
1473     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1474     PL_amagic_generation++;
1475
1476     return 0;
1477 }
1478
1479 int
1480 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1481 {
1482     HV * const hv = (HV*)LvTARG(sv);
1483     I32 i = 0;
1484     PERL_UNUSED_ARG(mg);
1485
1486     if (hv) {
1487          (void) hv_iterinit(hv);
1488          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1489              i = HvKEYS(hv);
1490          else {
1491              while (hv_iternext(hv))
1492                  i++;
1493          }
1494     }
1495
1496     sv_setiv(sv, (IV)i);
1497     return 0;
1498 }
1499
1500 int
1501 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1502 {
1503     PERL_UNUSED_ARG(mg);
1504     if (LvTARG(sv)) {
1505         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1506     }
1507     return 0;
1508 }
1509
1510 /* caller is responsible for stack switching/cleanup */
1511 STATIC int
1512 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1513 {
1514     dSP;
1515
1516     PUSHMARK(SP);
1517     EXTEND(SP, n);
1518     PUSHs(SvTIED_obj(sv, mg));
1519     if (n > 1) {
1520         if (mg->mg_ptr) {
1521             if (mg->mg_len >= 0)
1522                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1523             else if (mg->mg_len == HEf_SVKEY)
1524                 PUSHs((SV*)mg->mg_ptr);
1525         }
1526         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1527             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1528         }
1529     }
1530     if (n > 2) {
1531         PUSHs(val);
1532     }
1533     PUTBACK;
1534
1535     return call_method(meth, flags);
1536 }
1537
1538 STATIC int
1539 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1540 {
1541     dVAR; dSP;
1542
1543     ENTER;
1544     SAVETMPS;
1545     PUSHSTACKi(PERLSI_MAGIC);
1546
1547     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1548         sv_setsv(sv, *PL_stack_sp--);
1549     }
1550
1551     POPSTACK;
1552     FREETMPS;
1553     LEAVE;
1554     return 0;
1555 }
1556
1557 int
1558 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1559 {
1560     if (mg->mg_ptr)
1561         mg->mg_flags |= MGf_GSKIP;
1562     magic_methpack(sv,mg,"FETCH");
1563     return 0;
1564 }
1565
1566 int
1567 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1568 {
1569     dVAR; dSP;
1570     ENTER;
1571     PUSHSTACKi(PERLSI_MAGIC);
1572     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1573     POPSTACK;
1574     LEAVE;
1575     return 0;
1576 }
1577
1578 int
1579 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1580 {
1581     return magic_methpack(sv,mg,"DELETE");
1582 }
1583
1584
1585 U32
1586 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1587 {
1588     dVAR; dSP;
1589     U32 retval = 0;
1590
1591     ENTER;
1592     SAVETMPS;
1593     PUSHSTACKi(PERLSI_MAGIC);
1594     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1595         sv = *PL_stack_sp--;
1596         retval = (U32) SvIV(sv)-1;
1597     }
1598     POPSTACK;
1599     FREETMPS;
1600     LEAVE;
1601     return retval;
1602 }
1603
1604 int
1605 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1606 {
1607     dVAR; dSP;
1608
1609     ENTER;
1610     PUSHSTACKi(PERLSI_MAGIC);
1611     PUSHMARK(SP);
1612     XPUSHs(SvTIED_obj(sv, mg));
1613     PUTBACK;
1614     call_method("CLEAR", G_SCALAR|G_DISCARD);
1615     POPSTACK;
1616     LEAVE;
1617
1618     return 0;
1619 }
1620
1621 int
1622 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1623 {
1624     dVAR; dSP;
1625     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1626
1627     ENTER;
1628     SAVETMPS;
1629     PUSHSTACKi(PERLSI_MAGIC);
1630     PUSHMARK(SP);
1631     EXTEND(SP, 2);
1632     PUSHs(SvTIED_obj(sv, mg));
1633     if (SvOK(key))
1634         PUSHs(key);
1635     PUTBACK;
1636
1637     if (call_method(meth, G_SCALAR))
1638         sv_setsv(key, *PL_stack_sp--);
1639
1640     POPSTACK;
1641     FREETMPS;
1642     LEAVE;
1643     return 0;
1644 }
1645
1646 int
1647 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1648 {
1649     return magic_methpack(sv,mg,"EXISTS");
1650 }
1651
1652 SV *
1653 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1654 {
1655     dVAR; dSP;
1656     SV *retval = &PL_sv_undef;
1657     SV * const tied = SvTIED_obj((SV*)hv, mg);
1658     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1659
1660     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1661         SV *key;
1662         if (HvEITER_get(hv))
1663             /* we are in an iteration so the hash cannot be empty */
1664             return &PL_sv_yes;
1665         /* no xhv_eiter so now use FIRSTKEY */
1666         key = sv_newmortal();
1667         magic_nextpack((SV*)hv, mg, key);
1668         HvEITER_set(hv, NULL);     /* need to reset iterator */
1669         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1670     }
1671
1672     /* there is a SCALAR method that we can call */
1673     ENTER;
1674     PUSHSTACKi(PERLSI_MAGIC);
1675     PUSHMARK(SP);
1676     EXTEND(SP, 1);
1677     PUSHs(tied);
1678     PUTBACK;
1679
1680     if (call_method("SCALAR", G_SCALAR))
1681         retval = *PL_stack_sp--;
1682     POPSTACK;
1683     LEAVE;
1684     return retval;
1685 }
1686
1687 int
1688 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1689 {
1690     GV * const gv = PL_DBline;
1691     const I32 i = SvTRUE(sv);
1692     SV ** const svp = av_fetch(GvAV(gv),
1693                      atoi(MgPV_nolen_const(mg)), FALSE);
1694     if (svp && SvIOKp(*svp)) {
1695         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1696         if (o) {
1697             /* set or clear breakpoint in the relevant control op */
1698             if (i)
1699                 o->op_flags |= OPf_SPECIAL;
1700             else
1701                 o->op_flags &= ~OPf_SPECIAL;
1702         }
1703     }
1704     return 0;
1705 }
1706
1707 int
1708 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1709 {
1710     const AV * const obj = (AV*)mg->mg_obj;
1711     if (obj) {
1712         sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1713     } else {
1714         SvOK_off(sv);
1715     }
1716     return 0;
1717 }
1718
1719 int
1720 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1721 {
1722     AV * const obj = (AV*)mg->mg_obj;
1723     if (obj) {
1724         av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1725     } else {
1726         if (ckWARN(WARN_MISC))
1727             Perl_warner(aTHX_ packWARN(WARN_MISC),
1728                         "Attempt to set length of freed array");
1729     }
1730     return 0;
1731 }
1732
1733 int
1734 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1735 {
1736     PERL_UNUSED_ARG(sv);
1737     /* during global destruction, mg_obj may already have been freed */
1738     if (PL_in_clean_all)
1739         return 0;
1740
1741     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1742
1743     if (mg) {
1744         /* arylen scalar holds a pointer back to the array, but doesn't own a
1745            reference. Hence the we (the array) are about to go away with it
1746            still pointing at us. Clear its pointer, else it would be pointing
1747            at free memory. See the comment in sv_magic about reference loops,
1748            and why it can't own a reference to us.  */
1749         mg->mg_obj = 0;
1750     }
1751     return 0;
1752 }
1753
1754 int
1755 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1756 {
1757     SV* const lsv = LvTARG(sv);
1758
1759     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1760         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1761         if (mg && mg->mg_len >= 0) {
1762             I32 i = mg->mg_len;
1763             if (DO_UTF8(lsv))
1764                 sv_pos_b2u(lsv, &i);
1765             sv_setiv(sv, i + PL_curcop->cop_arybase);
1766             return 0;
1767         }
1768     }
1769     SvOK_off(sv);
1770     return 0;
1771 }
1772
1773 int
1774 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1775 {
1776     SV* const lsv = LvTARG(sv);
1777     SSize_t pos;
1778     STRLEN len;
1779     STRLEN ulen = 0;
1780
1781     mg = 0;
1782
1783     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1784         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1785     if (!mg) {
1786         if (!SvOK(sv))
1787             return 0;
1788         sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1789         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1790     }
1791     else if (!SvOK(sv)) {
1792         mg->mg_len = -1;
1793         return 0;
1794     }
1795     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1796
1797     pos = SvIV(sv) - PL_curcop->cop_arybase;
1798
1799     if (DO_UTF8(lsv)) {
1800         ulen = sv_len_utf8(lsv);
1801         if (ulen)
1802             len = ulen;
1803     }
1804
1805     if (pos < 0) {
1806         pos += len;
1807         if (pos < 0)
1808             pos = 0;
1809     }
1810     else if (pos > (SSize_t)len)
1811         pos = len;
1812
1813     if (ulen) {
1814         I32 p = pos;
1815         sv_pos_u2b(lsv, &p, 0);
1816         pos = p;
1817     }
1818
1819     mg->mg_len = pos;
1820     mg->mg_flags &= ~MGf_MINMATCH;
1821
1822     return 0;
1823 }
1824
1825 int
1826 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1827 {
1828     PERL_UNUSED_ARG(mg);
1829     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1830         SvFAKE_off(sv);
1831         gv_efullname3(sv,((GV*)sv), "*");
1832         SvFAKE_on(sv);
1833     }
1834     else
1835         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1836     return 0;
1837 }
1838
1839 int
1840 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1841 {
1842     GV* gv;
1843     PERL_UNUSED_ARG(mg);
1844
1845     if (!SvOK(sv))
1846         return 0;
1847     gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
1848     if (sv == (SV*)gv)
1849         return 0;
1850     if (GvGP(sv))
1851         gp_free((GV*)sv);
1852     GvGP(sv) = gp_ref(GvGP(gv));
1853     return 0;
1854 }
1855
1856 int
1857 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1858 {
1859     STRLEN len;
1860     SV * const lsv = LvTARG(sv);
1861     const char * const tmps = SvPV_const(lsv,len);
1862     I32 offs = LvTARGOFF(sv);
1863     I32 rem = LvTARGLEN(sv);
1864     PERL_UNUSED_ARG(mg);
1865
1866     if (SvUTF8(lsv))
1867         sv_pos_u2b(lsv, &offs, &rem);
1868     if (offs > (I32)len)
1869         offs = len;
1870     if (rem + offs > (I32)len)
1871         rem = len - offs;
1872     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1873     if (SvUTF8(lsv))
1874         SvUTF8_on(sv);
1875     return 0;
1876 }
1877
1878 int
1879 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1880 {
1881     STRLEN len;
1882     const char *tmps = SvPV_const(sv, len);
1883     SV * const lsv = LvTARG(sv);
1884     I32 lvoff = LvTARGOFF(sv);
1885     I32 lvlen = LvTARGLEN(sv);
1886     PERL_UNUSED_ARG(mg);
1887
1888     if (DO_UTF8(sv)) {
1889         sv_utf8_upgrade(lsv);
1890         sv_pos_u2b(lsv, &lvoff, &lvlen);
1891         sv_insert(lsv, lvoff, lvlen, tmps, len);
1892         LvTARGLEN(sv) = sv_len_utf8(sv);
1893         SvUTF8_on(lsv);
1894     }
1895     else if (lsv && SvUTF8(lsv)) {
1896         sv_pos_u2b(lsv, &lvoff, &lvlen);
1897         LvTARGLEN(sv) = len;
1898         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1899         sv_insert(lsv, lvoff, lvlen, tmps, len);
1900         Safefree(tmps);
1901     }
1902     else {
1903         sv_insert(lsv, lvoff, lvlen, tmps, len);
1904         LvTARGLEN(sv) = len;
1905     }
1906
1907
1908     return 0;
1909 }
1910
1911 int
1912 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1913 {
1914     PERL_UNUSED_ARG(sv);
1915     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1916     return 0;
1917 }
1918
1919 int
1920 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1921 {
1922     PERL_UNUSED_ARG(sv);
1923     /* update taint status unless we're restoring at scope exit */
1924     if (PL_localizing != 2) {
1925         if (PL_tainted)
1926             mg->mg_len |= 1;
1927         else
1928             mg->mg_len &= ~1;
1929     }
1930     return 0;
1931 }
1932
1933 int
1934 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1935 {
1936     SV * const lsv = LvTARG(sv);
1937     PERL_UNUSED_ARG(mg);
1938
1939     if (!lsv) {
1940         SvOK_off(sv);
1941         return 0;
1942     }
1943
1944     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1945     return 0;
1946 }
1947
1948 int
1949 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1950 {
1951     PERL_UNUSED_ARG(mg);
1952     do_vecset(sv);      /* XXX slurp this routine */
1953     return 0;
1954 }
1955
1956 int
1957 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1958 {
1959     SV *targ = Nullsv;
1960     if (LvTARGLEN(sv)) {
1961         if (mg->mg_obj) {
1962             SV * const ahv = LvTARG(sv);
1963             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1964             if (he)
1965                 targ = HeVAL(he);
1966         }
1967         else {
1968             AV* const av = (AV*)LvTARG(sv);
1969             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1970                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1971         }
1972         if (targ && targ != &PL_sv_undef) {
1973             /* somebody else defined it for us */
1974             SvREFCNT_dec(LvTARG(sv));
1975             LvTARG(sv) = SvREFCNT_inc(targ);
1976             LvTARGLEN(sv) = 0;
1977             SvREFCNT_dec(mg->mg_obj);
1978             mg->mg_obj = Nullsv;
1979             mg->mg_flags &= ~MGf_REFCOUNTED;
1980         }
1981     }
1982     else
1983         targ = LvTARG(sv);
1984     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1985     return 0;
1986 }
1987
1988 int
1989 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1990 {
1991     PERL_UNUSED_ARG(mg);
1992     if (LvTARGLEN(sv))
1993         vivify_defelem(sv);
1994     if (LvTARG(sv)) {
1995         sv_setsv(LvTARG(sv), sv);
1996         SvSETMAGIC(LvTARG(sv));
1997     }
1998     return 0;
1999 }
2000
2001 void
2002 Perl_vivify_defelem(pTHX_ SV *sv)
2003 {
2004     MAGIC *mg;
2005     SV *value = Nullsv;
2006
2007     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2008         return;
2009     if (mg->mg_obj) {
2010         SV * const ahv = LvTARG(sv);
2011         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2012         if (he)
2013             value = HeVAL(he);
2014         if (!value || value == &PL_sv_undef)
2015             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2016     }
2017     else {
2018         AV* const av = (AV*)LvTARG(sv);
2019         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2020             LvTARG(sv) = Nullsv;        /* array can't be extended */
2021         else {
2022             SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2023             if (!svp || (value = *svp) == &PL_sv_undef)
2024                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2025         }
2026     }
2027     (void)SvREFCNT_inc(value);
2028     SvREFCNT_dec(LvTARG(sv));
2029     LvTARG(sv) = value;
2030     LvTARGLEN(sv) = 0;
2031     SvREFCNT_dec(mg->mg_obj);
2032     mg->mg_obj = Nullsv;
2033     mg->mg_flags &= ~MGf_REFCOUNTED;
2034 }
2035
2036 int
2037 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2038 {
2039     AV *const av = (AV*)mg->mg_obj;
2040     SV **svp = AvARRAY(av);
2041     PERL_UNUSED_ARG(sv);
2042
2043     if (svp) {
2044         SV *const *const last = svp + AvFILLp(av);
2045
2046         while (svp <= last) {
2047             if (*svp) {
2048                 SV *const referrer = *svp;
2049                 if (SvWEAKREF(referrer)) {
2050                     /* XXX Should we check that it hasn't changed? */
2051                     SvRV_set(referrer, 0);
2052                     SvOK_off(referrer);
2053                     SvWEAKREF_off(referrer);
2054                 } else if (SvTYPE(referrer) == SVt_PVGV ||
2055                            SvTYPE(referrer) == SVt_PVLV) {
2056                     /* You lookin' at me?  */
2057                     assert(GvSTASH(referrer));
2058                     assert(GvSTASH(referrer) == (HV*)sv);
2059                     GvSTASH(referrer) = 0;
2060                 } else {
2061                     Perl_croak(aTHX_
2062                                "panic: magic_killbackrefs (flags=%"UVxf")",
2063                                (UV)SvFLAGS(referrer));
2064                 }
2065
2066                 *svp = Nullsv;
2067             }
2068             svp++;
2069         }
2070     }
2071     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2072     return 0;
2073 }
2074
2075 int
2076 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2077 {
2078     mg->mg_len = -1;
2079     SvSCREAM_off(sv);
2080     return 0;
2081 }
2082
2083 int
2084 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2085 {
2086     PERL_UNUSED_ARG(mg);
2087     sv_unmagic(sv, PERL_MAGIC_bm);
2088     SvVALID_off(sv);
2089     return 0;
2090 }
2091
2092 int
2093 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2094 {
2095     PERL_UNUSED_ARG(mg);
2096     sv_unmagic(sv, PERL_MAGIC_fm);
2097     SvCOMPILED_off(sv);
2098     return 0;
2099 }
2100
2101 int
2102 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2103 {
2104     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2105
2106     if (uf && uf->uf_set)
2107         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2108     return 0;
2109 }
2110
2111 int
2112 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2113 {
2114     PERL_UNUSED_ARG(mg);
2115     sv_unmagic(sv, PERL_MAGIC_qr);
2116     return 0;
2117 }
2118
2119 int
2120 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2121 {
2122     regexp * const re = (regexp *)mg->mg_obj;
2123     PERL_UNUSED_ARG(sv);
2124
2125     ReREFCNT_dec(re);
2126     return 0;
2127 }
2128
2129 #ifdef USE_LOCALE_COLLATE
2130 int
2131 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2132 {
2133     /*
2134      * RenE<eacute> Descartes said "I think not."
2135      * and vanished with a faint plop.
2136      */
2137     PERL_UNUSED_ARG(sv);
2138     if (mg->mg_ptr) {
2139         Safefree(mg->mg_ptr);
2140         mg->mg_ptr = NULL;
2141         mg->mg_len = -1;
2142     }
2143     return 0;
2144 }
2145 #endif /* USE_LOCALE_COLLATE */
2146
2147 /* Just clear the UTF-8 cache data. */
2148 int
2149 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2150 {
2151     PERL_UNUSED_ARG(sv);
2152     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2153     mg->mg_ptr = 0;
2154     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2155     return 0;
2156 }
2157
2158 int
2159 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2160 {
2161     register const char *s;
2162     I32 i;
2163     STRLEN len;
2164     switch (*mg->mg_ptr) {
2165     case '\001':        /* ^A */
2166         sv_setsv(PL_bodytarget, sv);
2167         break;
2168     case '\003':        /* ^C */
2169         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2170         break;
2171
2172     case '\004':        /* ^D */
2173 #ifdef DEBUGGING
2174         s = SvPV_nolen_const(sv);
2175         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2176         DEBUG_x(dump_all());
2177 #else
2178         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2179 #endif
2180         break;
2181     case '\005':  /* ^E */
2182         if (*(mg->mg_ptr+1) == '\0') {
2183 #ifdef MACOS_TRADITIONAL
2184             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2185 #else
2186 #  ifdef VMS
2187             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2188 #  else
2189 #    ifdef WIN32
2190             SetLastError( SvIV(sv) );
2191 #    else
2192 #      ifdef OS2
2193             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2194 #      else
2195             /* will anyone ever use this? */
2196             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2197 #      endif
2198 #    endif
2199 #  endif
2200 #endif
2201         }
2202         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2203             if (PL_encoding)
2204                 SvREFCNT_dec(PL_encoding);
2205             if (SvOK(sv) || SvGMAGICAL(sv)) {
2206                 PL_encoding = newSVsv(sv);
2207             }
2208             else {
2209                 PL_encoding = Nullsv;
2210             }
2211         }
2212         break;
2213     case '\006':        /* ^F */
2214         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2215         break;
2216     case '\010':        /* ^H */
2217         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2218         break;
2219     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2220         Safefree(PL_inplace);
2221         PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2222         break;
2223     case '\017':        /* ^O */
2224         if (*(mg->mg_ptr+1) == '\0') {
2225             Safefree(PL_osname);
2226             PL_osname = Nullch;
2227             if (SvOK(sv)) {
2228                 TAINT_PROPER("assigning to $^O");
2229                 PL_osname = savesvpv(sv);
2230             }
2231         }
2232         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2233             if (!PL_compiling.cop_io)
2234                 PL_compiling.cop_io = newSVsv(sv);
2235             else
2236                 sv_setsv(PL_compiling.cop_io,sv);
2237         }
2238         break;
2239     case '\020':        /* ^P */
2240         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2241         if (PL_perldb && !PL_DBsingle)
2242             init_debugger();
2243         break;
2244     case '\024':        /* ^T */
2245 #ifdef BIG_TIME
2246         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2247 #else
2248         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2249 #endif
2250         break;
2251     case '\027':        /* ^W & $^WARNING_BITS */
2252         if (*(mg->mg_ptr+1) == '\0') {
2253             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2254                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2255                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2256                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2257             }
2258         }
2259         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2260             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2261                 if (!SvPOK(sv) && PL_localizing) {
2262                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2263                     PL_compiling.cop_warnings = pWARN_NONE;
2264                     break;
2265                 }
2266                 {
2267                     STRLEN len, i;
2268                     int accumulate = 0 ;
2269                     int any_fatals = 0 ;
2270                     const char * const ptr = SvPV_const(sv, len) ;
2271                     for (i = 0 ; i < len ; ++i) {
2272                         accumulate |= ptr[i] ;
2273                         any_fatals |= (ptr[i] & 0xAA) ;
2274                     }
2275                     if (!accumulate)
2276                         PL_compiling.cop_warnings = pWARN_NONE;
2277                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2278                         PL_compiling.cop_warnings = pWARN_ALL;
2279                         PL_dowarn |= G_WARN_ONCE ;
2280                     }
2281                     else {
2282                         if (specialWARN(PL_compiling.cop_warnings))
2283                             PL_compiling.cop_warnings = newSVsv(sv) ;
2284                         else
2285                             sv_setsv(PL_compiling.cop_warnings, sv);
2286                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2287                             PL_dowarn |= G_WARN_ONCE ;
2288                     }
2289
2290                 }
2291             }
2292         }
2293         break;
2294     case '.':
2295         if (PL_localizing) {
2296             if (PL_localizing == 1)
2297                 SAVESPTR(PL_last_in_gv);
2298         }
2299         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2300             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2301         break;
2302     case '^':
2303         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2304         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2305         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2306         break;
2307     case '~':
2308         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2309         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2310         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
2311         break;
2312     case '=':
2313         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2314         break;
2315     case '-':
2316         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2317         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2318             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2319         break;
2320     case '%':
2321         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2322         break;
2323     case '|':
2324         {
2325             IO * const io = GvIOp(PL_defoutgv);
2326             if(!io)
2327               break;
2328             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2329                 IoFLAGS(io) &= ~IOf_FLUSH;
2330             else {
2331                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2332                     PerlIO *ofp = IoOFP(io);
2333                     if (ofp)
2334                         (void)PerlIO_flush(ofp);
2335                     IoFLAGS(io) |= IOf_FLUSH;
2336                 }
2337             }
2338         }
2339         break;
2340     case '/':
2341         SvREFCNT_dec(PL_rs);
2342         PL_rs = newSVsv(sv);
2343         break;
2344     case '\\':
2345         if (PL_ors_sv)
2346             SvREFCNT_dec(PL_ors_sv);
2347         if (SvOK(sv) || SvGMAGICAL(sv)) {
2348             PL_ors_sv = newSVsv(sv);
2349         }
2350         else {
2351             PL_ors_sv = Nullsv;
2352         }
2353         break;
2354     case ',':
2355         if (PL_ofs_sv)
2356             SvREFCNT_dec(PL_ofs_sv);
2357         if (SvOK(sv) || SvGMAGICAL(sv)) {
2358             PL_ofs_sv = newSVsv(sv);
2359         }
2360         else {
2361             PL_ofs_sv = Nullsv;
2362         }
2363         break;
2364     case '[':
2365         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2366         break;
2367     case '?':
2368 #ifdef COMPLEX_STATUS
2369         if (PL_localizing == 2) {
2370             PL_statusvalue = LvTARGOFF(sv);
2371             PL_statusvalue_vms = LvTARGLEN(sv);
2372         }
2373         else
2374 #endif
2375 #ifdef VMSISH_STATUS
2376         if (VMSISH_STATUS)
2377             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2378         else
2379 #endif
2380             STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2381         break;
2382     case '!':
2383         {
2384 #ifdef VMS
2385 #   define PERL_VMS_BANG vaxc$errno
2386 #else
2387 #   define PERL_VMS_BANG 0
2388 #endif
2389         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2390                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2391         }
2392         break;
2393     case '<':
2394         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2395         if (PL_delaymagic) {
2396             PL_delaymagic |= DM_RUID;
2397             break;                              /* don't do magic till later */
2398         }
2399 #ifdef HAS_SETRUID
2400         (void)setruid((Uid_t)PL_uid);
2401 #else
2402 #ifdef HAS_SETREUID
2403         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2404 #else
2405 #ifdef HAS_SETRESUID
2406       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2407 #else
2408         if (PL_uid == PL_euid) {                /* special case $< = $> */
2409 #ifdef PERL_DARWIN
2410             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2411             if (PL_uid != 0 && PerlProc_getuid() == 0)
2412                 (void)PerlProc_setuid(0);
2413 #endif
2414             (void)PerlProc_setuid(PL_uid);
2415         } else {
2416             PL_uid = PerlProc_getuid();
2417             Perl_croak(aTHX_ "setruid() not implemented");
2418         }
2419 #endif
2420 #endif
2421 #endif
2422         PL_uid = PerlProc_getuid();
2423         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2424         break;
2425     case '>':
2426         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2427         if (PL_delaymagic) {
2428             PL_delaymagic |= DM_EUID;
2429             break;                              /* don't do magic till later */
2430         }
2431 #ifdef HAS_SETEUID
2432         (void)seteuid((Uid_t)PL_euid);
2433 #else
2434 #ifdef HAS_SETREUID
2435         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2436 #else
2437 #ifdef HAS_SETRESUID
2438         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2439 #else
2440         if (PL_euid == PL_uid)          /* special case $> = $< */
2441             PerlProc_setuid(PL_euid);
2442         else {
2443             PL_euid = PerlProc_geteuid();
2444             Perl_croak(aTHX_ "seteuid() not implemented");
2445         }
2446 #endif
2447 #endif
2448 #endif
2449         PL_euid = PerlProc_geteuid();
2450         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2451         break;
2452     case '(':
2453         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2454         if (PL_delaymagic) {
2455             PL_delaymagic |= DM_RGID;
2456             break;                              /* don't do magic till later */
2457         }
2458 #ifdef HAS_SETRGID
2459         (void)setrgid((Gid_t)PL_gid);
2460 #else
2461 #ifdef HAS_SETREGID
2462         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2463 #else
2464 #ifdef HAS_SETRESGID
2465       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2466 #else
2467         if (PL_gid == PL_egid)                  /* special case $( = $) */
2468             (void)PerlProc_setgid(PL_gid);
2469         else {
2470             PL_gid = PerlProc_getgid();
2471             Perl_croak(aTHX_ "setrgid() not implemented");
2472         }
2473 #endif
2474 #endif
2475 #endif
2476         PL_gid = PerlProc_getgid();
2477         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2478         break;
2479     case ')':
2480 #ifdef HAS_SETGROUPS
2481         {
2482             const char *p = SvPV_const(sv, len);
2483             Groups_t gary[NGROUPS];
2484
2485             while (isSPACE(*p))
2486                 ++p;
2487             PL_egid = Atol(p);
2488             for (i = 0; i < NGROUPS; ++i) {
2489                 while (*p && !isSPACE(*p))
2490                     ++p;
2491                 while (isSPACE(*p))
2492                     ++p;
2493                 if (!*p)
2494                     break;
2495                 gary[i] = Atol(p);
2496             }
2497             if (i)
2498                 (void)setgroups(i, gary);
2499         }
2500 #else  /* HAS_SETGROUPS */
2501         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2502 #endif /* HAS_SETGROUPS */
2503         if (PL_delaymagic) {
2504             PL_delaymagic |= DM_EGID;
2505             break;                              /* don't do magic till later */
2506         }
2507 #ifdef HAS_SETEGID
2508         (void)setegid((Gid_t)PL_egid);
2509 #else
2510 #ifdef HAS_SETREGID
2511         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2512 #else
2513 #ifdef HAS_SETRESGID
2514         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2515 #else
2516         if (PL_egid == PL_gid)                  /* special case $) = $( */
2517             (void)PerlProc_setgid(PL_egid);
2518         else {
2519             PL_egid = PerlProc_getegid();
2520             Perl_croak(aTHX_ "setegid() not implemented");
2521         }
2522 #endif
2523 #endif
2524 #endif
2525         PL_egid = PerlProc_getegid();
2526         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2527         break;
2528     case ':':
2529         PL_chopset = SvPV_force(sv,len);
2530         break;
2531 #ifndef MACOS_TRADITIONAL
2532     case '0':
2533         LOCK_DOLLARZERO_MUTEX;
2534 #ifdef HAS_SETPROCTITLE
2535         /* The BSDs don't show the argv[] in ps(1) output, they
2536          * show a string from the process struct and provide
2537          * the setproctitle() routine to manipulate that. */
2538         {
2539             s = SvPV_const(sv, len);
2540 #   if __FreeBSD_version > 410001
2541             /* The leading "-" removes the "perl: " prefix,
2542              * but not the "(perl) suffix from the ps(1)
2543              * output, because that's what ps(1) shows if the
2544              * argv[] is modified. */
2545             setproctitle("-%s", s);
2546 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2547             /* This doesn't really work if you assume that
2548              * $0 = 'foobar'; will wipe out 'perl' from the $0
2549              * because in ps(1) output the result will be like
2550              * sprintf("perl: %s (perl)", s)
2551              * I guess this is a security feature:
2552              * one (a user process) cannot get rid of the original name.
2553              * --jhi */
2554             setproctitle("%s", s);
2555 #   endif
2556         }
2557 #endif
2558 #if defined(__hpux) && defined(PSTAT_SETCMD)
2559         {
2560              union pstun un;
2561              s = SvPV_const(sv, len);
2562              un.pst_command = (char *)s;
2563              pstat(PSTAT_SETCMD, un, len, 0, 0);
2564         }
2565 #endif
2566         /* PL_origalen is set in perl_parse(). */
2567         s = SvPV_force(sv,len);
2568         if (len >= (STRLEN)PL_origalen-1) {
2569             /* Longer than original, will be truncated. We assume that
2570              * PL_origalen bytes are available. */
2571             Copy(s, PL_origargv[0], PL_origalen-1, char);
2572         }
2573         else {
2574             /* Shorter than original, will be padded. */
2575             Copy(s, PL_origargv[0], len, char);
2576             PL_origargv[0][len] = 0;
2577             memset(PL_origargv[0] + len + 1,
2578                    /* Is the space counterintuitive?  Yes.
2579                     * (You were expecting \0?)
2580                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2581                     * --jhi */
2582                    (int)' ',
2583                    PL_origalen - len - 1);
2584         }
2585         PL_origargv[0][PL_origalen-1] = 0;
2586         for (i = 1; i < PL_origargc; i++)
2587             PL_origargv[i] = 0;
2588         UNLOCK_DOLLARZERO_MUTEX;
2589         break;
2590 #endif
2591     }
2592     return 0;
2593 }
2594
2595 I32
2596 Perl_whichsig(pTHX_ const char *sig)
2597 {
2598     register char* const* sigv;
2599
2600     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2601         if (strEQ(sig,*sigv))
2602             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2603 #ifdef SIGCLD
2604     if (strEQ(sig,"CHLD"))
2605         return SIGCLD;
2606 #endif
2607 #ifdef SIGCHLD
2608     if (strEQ(sig,"CLD"))
2609         return SIGCHLD;
2610 #endif
2611     return -1;
2612 }
2613
2614 Signal_t
2615 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2616 Perl_sighandler(int sig, ...)
2617 #else
2618 Perl_sighandler(int sig)
2619 #endif
2620 {
2621 #ifdef PERL_GET_SIG_CONTEXT
2622     dTHXa(PERL_GET_SIG_CONTEXT);
2623 #else
2624     dTHX;
2625 #endif
2626     dSP;
2627     GV *gv = Nullgv;
2628     SV *sv = Nullsv;
2629     SV * const tSv = PL_Sv;
2630     CV *cv = Nullcv;
2631     OP *myop = PL_op;
2632     U32 flags = 0;
2633     XPV * const tXpv = PL_Xpv;
2634
2635     if (PL_savestack_ix + 15 <= PL_savestack_max)
2636         flags |= 1;
2637     if (PL_markstack_ptr < PL_markstack_max - 2)
2638         flags |= 4;
2639     if (PL_scopestack_ix < PL_scopestack_max - 3)
2640         flags |= 16;
2641
2642     if (!PL_psig_ptr[sig]) {
2643                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2644                                  PL_sig_name[sig]);
2645                 exit(sig);
2646         }
2647
2648     /* Max number of items pushed there is 3*n or 4. We cannot fix
2649        infinity, so we fix 4 (in fact 5): */
2650     if (flags & 1) {
2651         PL_savestack_ix += 5;           /* Protect save in progress. */
2652         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2653     }
2654     if (flags & 4)
2655         PL_markstack_ptr++;             /* Protect mark. */
2656     if (flags & 16)
2657         PL_scopestack_ix += 1;
2658     /* sv_2cv is too complicated, try a simpler variant first: */
2659     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2660         || SvTYPE(cv) != SVt_PVCV) {
2661         HV *st;
2662         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2663     }
2664
2665     if (!cv || !CvROOT(cv)) {
2666         if (ckWARN(WARN_SIGNAL))
2667             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2668                 PL_sig_name[sig], (gv ? GvENAME(gv)
2669                                 : ((cv && CvGV(cv))
2670                                    ? GvENAME(CvGV(cv))
2671                                    : "__ANON__")));
2672         goto cleanup;
2673     }
2674
2675     if(PL_psig_name[sig]) {
2676         sv = SvREFCNT_inc(PL_psig_name[sig]);
2677         flags |= 64;
2678 #if !defined(PERL_IMPLICIT_CONTEXT)
2679         PL_sig_sv = sv;
2680 #endif
2681     } else {
2682         sv = sv_newmortal();
2683         sv_setpv(sv,PL_sig_name[sig]);
2684     }
2685
2686     PUSHSTACKi(PERLSI_SIGNAL);
2687     PUSHMARK(SP);
2688     PUSHs(sv);
2689 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2690     {
2691          struct sigaction oact;
2692
2693          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2694               siginfo_t *sip;
2695               va_list args;
2696
2697               va_start(args, sig);
2698               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2699               if (sip) {
2700                    HV *sih = newHV();
2701                    SV *rv  = newRV_noinc((SV*)sih);
2702                    /* The siginfo fields signo, code, errno, pid, uid,
2703                     * addr, status, and band are defined by POSIX/SUSv3. */
2704                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2705                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2706 #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. */
2707                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2708                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2709                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2710                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2711                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2712                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2713 #endif
2714                    EXTEND(SP, 2);
2715                    PUSHs((SV*)rv);
2716                    PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2717               }
2718
2719               va_end(args);
2720          }
2721     }
2722 #endif
2723     PUTBACK;
2724
2725     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2726
2727     POPSTACK;
2728     if (SvTRUE(ERRSV)) {
2729 #ifndef PERL_MICRO
2730 #ifdef HAS_SIGPROCMASK
2731         /* Handler "died", for example to get out of a restart-able read().
2732          * Before we re-do that on its behalf re-enable the signal which was
2733          * blocked by the system when we entered.
2734          */
2735         sigset_t set;
2736         sigemptyset(&set);
2737         sigaddset(&set,sig);
2738         sigprocmask(SIG_UNBLOCK, &set, NULL);
2739 #else
2740         /* Not clear if this will work */
2741         (void)rsignal(sig, SIG_IGN);
2742         (void)rsignal(sig, PL_csighandlerp);
2743 #endif
2744 #endif /* !PERL_MICRO */
2745         Perl_die(aTHX_ Nullch);
2746     }
2747 cleanup:
2748     if (flags & 1)
2749         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2750     if (flags & 4)
2751         PL_markstack_ptr--;
2752     if (flags & 16)
2753         PL_scopestack_ix -= 1;
2754     if (flags & 64)
2755         SvREFCNT_dec(sv);
2756     PL_op = myop;                       /* Apparently not needed... */
2757
2758     PL_Sv = tSv;                        /* Restore global temporaries. */
2759     PL_Xpv = tXpv;
2760     return;
2761 }
2762
2763
2764 static void
2765 S_restore_magic(pTHX_ const void *p)
2766 {
2767     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2768     SV* const sv = mgs->mgs_sv;
2769
2770     if (!sv)
2771         return;
2772
2773     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2774     {
2775 #ifdef PERL_OLD_COPY_ON_WRITE
2776         /* While magic was saved (and off) sv_setsv may well have seen
2777            this SV as a prime candidate for COW.  */
2778         if (SvIsCOW(sv))
2779             sv_force_normal_flags(sv, 0);
2780 #endif
2781
2782         if (mgs->mgs_flags)
2783             SvFLAGS(sv) |= mgs->mgs_flags;
2784         else
2785             mg_magical(sv);
2786         if (SvGMAGICAL(sv)) {
2787             /* downgrade public flags to private,
2788                and discard any other private flags */
2789
2790             U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2791             if (public) {
2792                 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2793                 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2794             }
2795         }
2796     }
2797
2798     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2799
2800     /* If we're still on top of the stack, pop us off.  (That condition
2801      * will be satisfied if restore_magic was called explicitly, but *not*
2802      * if it's being called via leave_scope.)
2803      * The reason for doing this is that otherwise, things like sv_2cv()
2804      * may leave alloc gunk on the savestack, and some code
2805      * (e.g. sighandler) doesn't expect that...
2806      */
2807     if (PL_savestack_ix == mgs->mgs_ss_ix)
2808     {
2809         I32 popval = SSPOPINT;
2810         assert(popval == SAVEt_DESTRUCTOR_X);
2811         PL_savestack_ix -= 2;
2812         popval = SSPOPINT;
2813         assert(popval == SAVEt_ALLOC);
2814         popval = SSPOPINT;
2815         PL_savestack_ix -= popval;
2816     }
2817
2818 }
2819
2820 static void
2821 S_unwind_handler_stack(pTHX_ const void *p)
2822 {
2823     dVAR;
2824     const U32 flags = *(const U32*)p;
2825
2826     if (flags & 1)
2827         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2828     /* cxstack_ix-- Not needed, die already unwound it. */
2829 #if !defined(PERL_IMPLICIT_CONTEXT)
2830     if (flags & 64)
2831         SvREFCNT_dec(PL_sig_sv);
2832 #endif
2833 }
2834
2835 /*
2836  * Local variables:
2837  * c-indentation-style: bsd
2838  * c-basic-offset: 4
2839  * indent-tabs-mode: t
2840  * End:
2841  *
2842  * ex: set ts=8 sts=4 sw=4 noet:
2843  */