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