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     PERL_UNUSED_ARG(sv);
 489
 490     if (PL_curpm) {
 491         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 492         if (rx) {
 493             return mg->mg_obj
 494                 ? rx->nparens       /* @+ */
 495                 : rx->lastparen;    /* @- */
 496         }
 497     }
 498
 499     return (U32)-1;
 500 }
 501
 502 int
 503 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 504 {
 505     if (PL_curpm) {
 506         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 507         if (rx) {
 508             register const I32 paren = mg->mg_len;
 509             register I32 s;
 510             register I32 t;
 511             if (paren < 0)
 512                 return 0;
 513             if (paren <= (I32)rx->nparens &&
 514                 (s = rx->startp[paren]) != -1 &&
 515                 (t = rx->endp[paren]) != -1)
 516                 {
 517                     register I32 i;
 518                     if (mg->mg_obj)             /* @+ */
 519                         i = t;
 520                     else                        /* @- */
 521                         i = s;
 522
 523                     if (i > 0 && RX_MATCH_UTF8(rx)) {
 524                         const char * const b = rx->subbeg;
 525                         if (b)
 526                             i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
 527                     }
 528
 529                     sv_setiv(sv, i);
 530                 }
 531         }
 532     }
 533     return 0;
 534 }
 535
 536 int
 537 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 538 {
 539     PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
 540     Perl_croak(aTHX_ PL_no_modify);
 541     NORETURN_FUNCTION_END;
 542 }
 543
 544 U32
 545 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 546 {
 547     register I32 paren;
 548     register I32 i;
 549     register const REGEXP *rx;
 550     I32 s1, t1;
 551
 552     switch (*mg->mg_ptr) {
 553     case '1': case '2': case '3': case '4':
 554     case '5': case '6': case '7': case '8': case '9': case '&':
 555         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 556
 557             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 558           getparen:
 559             if (paren <= (I32)rx->nparens &&
 560                 (s1 = rx->startp[paren]) != -1 &&
 561                 (t1 = rx->endp[paren]) != -1)
 562             {
 563                 i = t1 - s1;
 564               getlen:
 565                 if (i > 0 && RX_MATCH_UTF8(rx)) {
 566                     const char * const s = rx->subbeg + s1;
 567                     const U8 *ep;
 568                     STRLEN el;
 569
 570                     i = t1 - s1;
 571                     if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
 572                         i = el;
 573                 }
 574                 if (i < 0)
 575                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 576                 return i;
 577             }
 578             else {
 579                 if (ckWARN(WARN_UNINITIALIZED))
 580                     report_uninit(sv);
 581             }
 582         }
 583         else {
 584             if (ckWARN(WARN_UNINITIALIZED))
 585                 report_uninit(sv);
 586         }
 587         return 0;
 588     case '+':
 589         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 590             paren = rx->lastparen;
 591             if (paren)
 592                 goto getparen;
 593         }
 594         return 0;
 595     case '\016': /* ^N */
 596         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 597             paren = rx->lastcloseparen;
 598             if (paren)
 599                 goto getparen;
 600         }
 601         return 0;
 602     case '`':
 603         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 604             if (rx->startp[0] != -1) {
 605                 i = rx->startp[0];
 606                 if (i > 0) {
 607                     s1 = 0;
 608                     t1 = i;
 609                     goto getlen;
 610                 }
 611             }
 612         }
 613         return 0;
 614     case '\'':
 615         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 616             if (rx->endp[0] != -1) {
 617                 i = rx->sublen - rx->endp[0];
 618                 if (i > 0) {
 619                     s1 = rx->endp[0];
 620                     t1 = rx->sublen;
 621                     goto getlen;
 622                 }
 623             }
 624         }
 625         return 0;
 626     }
 627     magic_get(sv,mg);
 628     if (!SvPOK(sv) && SvNIOK(sv)) {
 629         sv_2pv(sv, 0);
 630     }
 631     if (SvPOK(sv))
 632         return SvCUR(sv);
 633     return 0;
 634 }
 635
 636 #define SvRTRIM(sv) STMT_START { \
 637     STRLEN len = SvCUR(sv); \
 638     while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
 639         --len; \
 640     SvCUR_set(sv, len); \
 641 } STMT_END
 642
 643 int
 644 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 645 {
 646     dVAR;
 647     register I32 paren;
 648     register char *s = NULL;
 649     register I32 i;
 650     register REGEXP *rx;
 651     const char * const remaining = mg->mg_ptr + 1;
 652     const char nextchar = *remaining;
 653
 654     switch (*mg->mg_ptr) {
 655     case '\001':                /* ^A */
 656         sv_setsv(sv, PL_bodytarget);
 657         break;
 658     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 659         if (nextchar == '\0') {
 660             sv_setiv(sv, (IV)PL_minus_c);
 661         }
 662         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 663             sv_setiv(sv, (IV)STATUS_NATIVE);
 664         }
 665         break;
 666
 667     case '\004':                /* ^D */
 668         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 669         break;
 670     case '\005':  /* ^E */
 671          if (nextchar == '\0') {
 672 #ifdef MACOS_TRADITIONAL
 673              {
 674                   char msg[256];
 675
 676                   sv_setnv(sv,(double)gMacPerl_OSErr);
 677                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 678              }
 679 #else
 680 #ifdef VMS
 681              {
 682 #                 include <descrip.h>
 683 #                 include <starlet.h>
 684                   char msg[255];
 685                   $DESCRIPTOR(msgdsc,msg);
 686                   sv_setnv(sv,(NV) vaxc$errno);
 687                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 688                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 689                   else
 690                        sv_setpvn(sv,"",0);
 691              }
 692 #else
 693 #ifdef OS2
 694              if (!(_emx_env & 0x200)) { /* Under DOS */
 695                   sv_setnv(sv, (NV)errno);
 696                   sv_setpv(sv, errno ? Strerror(errno) : "");
 697              } else {
 698                   if (errno != errno_isOS2) {
 699                        const int tmp = _syserrno();
 700                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 701                             Perl_rc = tmp;
 702                   }
 703                   sv_setnv(sv, (NV)Perl_rc);
 704                   sv_setpv(sv, os2error(Perl_rc));
 705              }
 706 #else
 707 #ifdef WIN32
 708              {
 709                   DWORD dwErr = GetLastError();
 710                   sv_setnv(sv, (NV)dwErr);
 711                   if (dwErr) {
 712                        PerlProc_GetOSError(sv, dwErr);
 713                   }
 714                   else
 715                        sv_setpvn(sv, "", 0);
 716                   SetLastError(dwErr);
 717              }
 718 #else
 719              {
 720                  const int saveerrno = errno;
 721                  sv_setnv(sv, (NV)errno);
 722                  sv_setpv(sv, errno ? Strerror(errno) : "");
 723                  errno = saveerrno;
 724              }
 725 #endif
 726 #endif
 727 #endif
 728 #endif
 729              SvRTRIM(sv);
 730              SvNOK_on(sv);      /* what a wonderful hack! */
 731          }
 732          else if (strEQ(remaining, "NCODING"))
 733               sv_setsv(sv, PL_encoding);
 734          break;
 735     case '\006':                /* ^F */
 736         sv_setiv(sv, (IV)PL_maxsysfd);
 737         break;
 738     case '\010':                /* ^H */
 739         sv_setiv(sv, (IV)PL_hints);
 740         break;
 741     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 742         if (PL_inplace)
 743             sv_setpv(sv, PL_inplace);
 744         else
 745             sv_setsv(sv, &PL_sv_undef);
 746         break;
 747     case '\017':                /* ^O & ^OPEN */
 748         if (nextchar == '\0') {
 749             sv_setpv(sv, PL_osname);
 750             SvTAINTED_off(sv);
 751         }
 752         else if (strEQ(remaining, "PEN")) {
 753             if (!PL_compiling.cop_io)
 754                 sv_setsv(sv, &PL_sv_undef);
 755             else {
 756                 sv_setsv(sv, PL_compiling.cop_io);
 757             }
 758         }
 759         break;
 760     case '\020':                /* ^P */
 761         sv_setiv(sv, (IV)PL_perldb);
 762         break;
 763     case '\023':                /* ^S */
 764         if (nextchar == '\0') {
 765             if (PL_lex_state != LEX_NOTPARSING)
 766                 SvOK_off(sv);
 767             else if (PL_in_eval)
 768                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 769             else
 770                 sv_setiv(sv, 0);
 771         }
 772         break;
 773     case '\024':                /* ^T */
 774         if (nextchar == '\0') {
 775 #ifdef BIG_TIME
 776             sv_setnv(sv, PL_basetime);
 777 #else
 778             sv_setiv(sv, (IV)PL_basetime);
 779 #endif
 780         }
 781         else if (strEQ(remaining, "AINT"))
 782             sv_setiv(sv, PL_tainting
 783                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 784                     : 0);
 785         break;
 786     case '\025':                /* $^UNICODE, $^UTF8LOCALE */
 787         if (strEQ(remaining, "NICODE"))
 788             sv_setuv(sv, (UV) PL_unicode);
 789         else if (strEQ(remaining, "TF8LOCALE"))
 790             sv_setuv(sv, (UV) PL_utf8locale);
 791         break;
 792     case '\027':                /* ^W  & $^WARNING_BITS */
 793         if (nextchar == '\0')
 794             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 795         else if (strEQ(remaining, "ARNING_BITS")) {
 796             if (PL_compiling.cop_warnings == pWARN_NONE) {
 797                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 798             }
 799             else if (PL_compiling.cop_warnings == pWARN_STD) {
 800                 sv_setpvn(
 801                     sv,
 802                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 803                     WARNsize
 804                 );
 805             }
 806             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 807                 /* Get the bit mask for $warnings::Bits{all}, because
 808                  * it could have been extended by warnings::register */
 809                 SV **bits_all;
 810                 HV * const bits=get_hv("warnings::Bits", FALSE);
 811                 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
 812                     sv_setsv(sv, *bits_all);
 813                 }
 814                 else {
 815                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 816                 }
 817             }
 818             else {
 819                 sv_setsv(sv, PL_compiling.cop_warnings);
 820             }
 821             SvPOK_only(sv);
 822         }
 823         break;
 824     case '1': case '2': case '3': case '4':
 825     case '5': case '6': case '7': case '8': case '9': case '&':
 826         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 827             I32 s1, t1;
 828
 829             /*
 830              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 831              * XXX Does the new way break anything?
 832              */
 833             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 834           getparen:
 835             if (paren <= (I32)rx->nparens &&
 836                 (s1 = rx->startp[paren]) != -1 &&
 837                 (t1 = rx->endp[paren]) != -1)
 838             {
 839                 i = t1 - s1;
 840                 s = rx->subbeg + s1;
 841                 if (!rx->subbeg)
 842                     break;
 843
 844               getrx:
 845                 if (i >= 0) {
 846                     int oldtainted = PL_tainted;
 847                     TAINT_NOT;
 848                     sv_setpvn(sv, s, i);
 849                     PL_tainted = oldtainted;
 850                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 851                         SvUTF8_on(sv);
 852                     else
 853                         SvUTF8_off(sv);
 854                     if (PL_tainting) {
 855                         if (RX_MATCH_TAINTED(rx)) {
 856                             MAGIC* const mg = SvMAGIC(sv);
 857                             MAGIC* mgt;
 858                             PL_tainted = 1;
 859                             SvMAGIC_set(sv, mg->mg_moremagic);
 860                             SvTAINT(sv);
 861                             if ((mgt = SvMAGIC(sv))) {
 862                                 mg->mg_moremagic = mgt;
 863                                 SvMAGIC_set(sv, mg);
 864                             }
 865                         } else
 866                             SvTAINTED_off(sv);
 867                     }
 868                     break;
 869                 }
 870             }
 871         }
 872         sv_setsv(sv,&PL_sv_undef);
 873         break;
 874     case '+':
 875         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 876             paren = rx->lastparen;
 877             if (paren)
 878                 goto getparen;
 879         }
 880         sv_setsv(sv,&PL_sv_undef);
 881         break;
 882     case '\016':                /* ^N */
 883         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 884             paren = rx->lastcloseparen;
 885             if (paren)
 886                 goto getparen;
 887         }
 888         sv_setsv(sv,&PL_sv_undef);
 889         break;
 890     case '`':
 891         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 892             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 893                 i = rx->startp[0];
 894                 goto getrx;
 895             }
 896         }
 897         sv_setsv(sv,&PL_sv_undef);
 898         break;
 899     case '\'':
 900         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 901             if (rx->subbeg && rx->endp[0] != -1) {
 902                 s = rx->subbeg + rx->endp[0];
 903                 i = rx->sublen - rx->endp[0];
 904                 goto getrx;
 905             }
 906         }
 907         sv_setsv(sv,&PL_sv_undef);
 908         break;
 909     case '.':
 910         if (GvIO(PL_last_in_gv)) {
 911             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 912         }
 913         break;
 914     case '?':
 915         {
 916             sv_setiv(sv, (IV)STATUS_CURRENT);
 917 #ifdef COMPLEX_STATUS
 918             LvTARGOFF(sv) = PL_statusvalue;
 919             LvTARGLEN(sv) = PL_statusvalue_vms;
 920 #endif
 921         }
 922         break;
 923     case '^':
 924         if (GvIOp(PL_defoutgv))
 925             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 926         if (s)
 927             sv_setpv(sv,s);
 928         else {
 929             sv_setpv(sv,GvENAME(PL_defoutgv));
 930             sv_catpv(sv,"_TOP");
 931         }
 932         break;
 933     case '~':
 934         if (GvIOp(PL_defoutgv))
 935             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 936         if (!s)
 937             s = GvENAME(PL_defoutgv);
 938         sv_setpv(sv,s);
 939         break;
 940     case '=':
 941         if (GvIOp(PL_defoutgv))
 942             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 943         break;
 944     case '-':
 945         if (GvIOp(PL_defoutgv))
 946             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 947         break;
 948     case '%':
 949         if (GvIOp(PL_defoutgv))
 950             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 951         break;
 952     case ':':
 953         break;
 954     case '/':
 955         break;
 956     case '[':
 957         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 958         break;
 959     case '|':
 960         if (GvIOp(PL_defoutgv))
 961             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 962         break;
 963     case ',':
 964         break;
 965     case '\\':
 966         if (PL_ors_sv)
 967             sv_copypv(sv, PL_ors_sv);
 968         break;
 969     case '!':
 970 #ifdef VMS
 971         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 972         sv_setpv(sv, errno ? Strerror(errno) : "");
 973 #else
 974         {
 975         const int saveerrno = errno;
 976         sv_setnv(sv, (NV)errno);
 977 #ifdef OS2
 978         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 979             sv_setpv(sv, os2error(Perl_rc));
 980         else
 981 #endif
 982         sv_setpv(sv, errno ? Strerror(errno) : "");
 983         errno = saveerrno;
 984         }
 985 #endif
 986         SvRTRIM(sv);
 987         SvNOK_on(sv);   /* what a wonderful hack! */
 988         break;
 989     case '<':
 990         sv_setiv(sv, (IV)PL_uid);
 991         break;
 992     case '>':
 993         sv_setiv(sv, (IV)PL_euid);
 994         break;
 995     case '(':
 996         sv_setiv(sv, (IV)PL_gid);
 997 #ifdef HAS_GETGROUPS
 998         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_gid);
 999 #endif
1000         goto add_groups;
1001     case ')':
1002         sv_setiv(sv, (IV)PL_egid);
1003 #ifdef HAS_GETGROUPS
1004         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)PL_egid);
1005 #endif
1006       add_groups:
1007 #ifdef HAS_GETGROUPS
1008         {
1009             Groups_t *gary = NULL;
1010             I32 num_groups = getgroups(0, gary);
1011             Newx(gary, num_groups, Groups_t);
1012             num_groups = getgroups(num_groups, gary);
1013             while (--num_groups >= 0)
1014                 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
1015                     (long unsigned int)gary[num_groups]);
1016             Safefree(gary);
1017         }
1018 #endif
1019         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1020         break;
1021 #ifndef MACOS_TRADITIONAL
1022     case '0':
1023         break;
1024 #endif
1025     }
1026     return 0;
1027 }
1028
1029 int
1030 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1031 {
1032     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1033
1034     if (uf && uf->uf_val)
1035         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1036     return 0;
1037 }
1038
1039 int
1040 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1041 {
1042     dVAR;
1043     const char *s;
1044     const char *ptr;
1045     STRLEN len, klen;
1046
1047     s = SvPV_const(sv,len);
1048     ptr = MgPV_const(mg,klen);
1049     my_setenv(ptr, s);
1050
1051 #ifdef DYNAMIC_ENV_FETCH
1052      /* We just undefd an environment var.  Is a replacement */
1053      /* waiting in the wings? */
1054     if (!len) {
1055         SV **valp;
1056         if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
1057             s = SvPV_const(*valp, len);
1058     }
1059 #endif
1060
1061 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1062                             /* And you'll never guess what the dog had */
1063                             /*   in its mouth... */
1064     if (PL_tainting) {
1065         MgTAINTEDDIR_off(mg);
1066 #ifdef VMS
1067         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1068             char pathbuf[256], eltbuf[256], *cp, *elt;
1069             Stat_t sbuf;
1070             int i = 0, j = 0;
1071
1072             strncpy(eltbuf, s, 255);
1073             eltbuf[255] = 0;
1074             elt = eltbuf;
1075             do {          /* DCL$PATH may be a search list */
1076                 while (1) {   /* as may dev portion of any element */
1077                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1078                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1079                              cando_by_name(S_IWUSR,0,elt) ) {
1080                             MgTAINTEDDIR_on(mg);
1081                             return 0;
1082                         }
1083                     }
1084                     if ((cp = strchr(elt, ':')) != Nullch)
1085                         *cp = '\0';
1086                     if (my_trnlnm(elt, eltbuf, j++))
1087                         elt = eltbuf;
1088                     else
1089                         break;
1090                 }
1091                 j = 0;
1092             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1093         }
1094 #endif /* VMS */
1095         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1096             const char * const strend = s + len;
1097
1098             while (s < strend) {
1099                 char tmpbuf[256];
1100                 Stat_t st;
1101                 I32 i;
1102                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1103                              s, strend, ':', &i);
1104                 s++;
1105                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1106                       || *tmpbuf != '/'
1107                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1108                     MgTAINTEDDIR_on(mg);
1109                     return 0;
1110                 }
1111             }
1112         }
1113     }
1114 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1115
1116     return 0;
1117 }
1118
1119 int
1120 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1121 {
1122     PERL_UNUSED_ARG(sv);
1123     my_setenv(MgPV_nolen_const(mg),Nullch);
1124     return 0;
1125 }
1126
1127 int
1128 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1129 {
1130     PERL_UNUSED_ARG(mg);
1131 #if defined(VMS)
1132     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1133 #else
1134     if (PL_localizing) {
1135         HE* entry;
1136         my_clearenv();
1137         hv_iterinit((HV*)sv);
1138         while ((entry = hv_iternext((HV*)sv))) {
1139             I32 keylen;
1140             my_setenv(hv_iterkey(entry, &keylen),
1141                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1142         }
1143     }
1144 #endif
1145     return 0;
1146 }
1147
1148 int
1149 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1150 {
1151     dVAR;
1152     PERL_UNUSED_ARG(sv);
1153     PERL_UNUSED_ARG(mg);
1154 #if defined(VMS)
1155     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1156 #else
1157     my_clearenv();
1158 #endif
1159     return 0;
1160 }
1161
1162 #ifndef PERL_MICRO
1163 #ifdef HAS_SIGPROCMASK
1164 static void
1165 restore_sigmask(pTHX_ SV *save_sv)
1166 {
1167     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1168     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1169 }
1170 #endif
1171 int
1172 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1173 {
1174     /* Are we fetching a signal entry? */
1175     const I32 i = whichsig(MgPV_nolen_const(mg));
1176     if (i > 0) {
1177         if(PL_psig_ptr[i])
1178             sv_setsv(sv,PL_psig_ptr[i]);
1179         else {
1180             Sighandler_t sigstate;
1181             sigstate = rsignal_state(i);
1182 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1183             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1184 #endif
1185 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1186             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1187 #endif
1188             /* cache state so we don't fetch it again */
1189             if(sigstate == (Sighandler_t) SIG_IGN)
1190                 sv_setpv(sv,"IGNORE");
1191             else
1192                 sv_setsv(sv,&PL_sv_undef);
1193             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1194             SvTEMP_off(sv);
1195         }
1196     }
1197     return 0;
1198 }
1199 int
1200 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1201 {
1202     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1203      * refactoring might be in order.
1204      */
1205     dVAR;
1206     register const char * const s = MgPV_nolen_const(mg);
1207     PERL_UNUSED_ARG(sv);
1208     if (*s == '_') {
1209         SV** svp = 0;
1210         if (strEQ(s,"__DIE__"))
1211             svp = &PL_diehook;
1212         else if (strEQ(s,"__WARN__"))
1213             svp = &PL_warnhook;
1214         else
1215             Perl_croak(aTHX_ "No such hook: %s", s);
1216         if (svp && *svp) {
1217             SV * const to_dec = *svp;
1218             *svp = 0;
1219             SvREFCNT_dec(to_dec);
1220         }
1221     }
1222     else {
1223         /* Are we clearing a signal entry? */
1224         const I32 i = whichsig(s);
1225         if (i > 0) {
1226 #ifdef HAS_SIGPROCMASK
1227             sigset_t set, save;
1228             SV* save_sv;
1229             /* Avoid having the signal arrive at a bad time, if possible. */
1230             sigemptyset(&set);
1231             sigaddset(&set,i);
1232             sigprocmask(SIG_BLOCK, &set, &save);
1233             ENTER;
1234             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1235             SAVEFREESV(save_sv);
1236             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1237 #endif
1238             PERL_ASYNC_CHECK();
1239 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1240             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1241 #endif
1242 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1243             PL_sig_defaulting[i] = 1;
1244             (void)rsignal(i, PL_csighandlerp);
1245 #else
1246             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1247 #endif
1248             if(PL_psig_name[i]) {
1249                 SvREFCNT_dec(PL_psig_name[i]);
1250                 PL_psig_name[i]=0;
1251             }
1252             if(PL_psig_ptr[i]) {
1253                 SV *to_dec=PL_psig_ptr[i];
1254                 PL_psig_ptr[i]=0;
1255                 LEAVE;
1256                 SvREFCNT_dec(to_dec);
1257             }
1258             else
1259                 LEAVE;
1260         }
1261     }
1262     return 0;
1263 }
1264
1265 static void
1266 S_raise_signal(pTHX_ int sig)
1267 {
1268     /* Set a flag to say this signal is pending */
1269     PL_psig_pend[sig]++;
1270     /* And one to say _a_ signal is pending */
1271     PL_sig_pending = 1;
1272 }
1273
1274 Signal_t
1275 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1276 Perl_csighandler(int sig, ...)
1277 #else
1278 Perl_csighandler(int sig)
1279 #endif
1280 {
1281 #ifdef PERL_GET_SIG_CONTEXT
1282     dTHXa(PERL_GET_SIG_CONTEXT);
1283 #else
1284     dTHX;
1285 #endif
1286 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1287     (void) rsignal(sig, PL_csighandlerp);
1288     if (PL_sig_ignoring[sig]) return;
1289 #endif
1290 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1291     if (PL_sig_defaulting[sig])
1292 #ifdef KILL_BY_SIGPRC
1293             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1294 #else
1295             exit(1);
1296 #endif
1297 #endif
1298    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1299         /* Call the perl level handler now--
1300          * with risk we may be in malloc() etc. */
1301         (*PL_sighandlerp)(sig);
1302    else
1303         S_raise_signal(aTHX_ sig);
1304 }
1305
1306 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1307 void
1308 Perl_csighandler_init(void)
1309 {
1310     int sig;
1311     if (PL_sig_handlers_initted) return;
1312
1313     for (sig = 1; sig < SIG_SIZE; sig++) {
1314 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1315         dTHX;
1316         PL_sig_defaulting[sig] = 1;
1317         (void) rsignal(sig, PL_csighandlerp);
1318 #endif
1319 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1320         PL_sig_ignoring[sig] = 0;
1321 #endif
1322     }
1323     PL_sig_handlers_initted = 1;
1324 }
1325 #endif
1326
1327 void
1328 Perl_despatch_signals(pTHX)
1329 {
1330     int sig;
1331     PL_sig_pending = 0;
1332     for (sig = 1; sig < SIG_SIZE; sig++) {
1333         if (PL_psig_pend[sig]) {
1334             PERL_BLOCKSIG_ADD(set, sig);
1335             PL_psig_pend[sig] = 0;
1336             PERL_BLOCKSIG_BLOCK(set);
1337             (*PL_sighandlerp)(sig);
1338             PERL_BLOCKSIG_UNBLOCK(set);
1339         }
1340     }
1341 }
1342
1343 int
1344 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1345 {
1346     dVAR;
1347     I32 i;
1348     SV** svp = 0;
1349     /* Need to be careful with SvREFCNT_dec(), because that can have side
1350      * effects (due to closures). We must make sure that the new disposition
1351      * is in place before it is called.
1352      */
1353     SV* to_dec = 0;
1354     STRLEN len;
1355 #ifdef HAS_SIGPROCMASK
1356     sigset_t set, save;
1357     SV* save_sv;
1358 #endif
1359
1360     register const char *s = MgPV_const(mg,len);
1361     if (*s == '_') {
1362         if (strEQ(s,"__DIE__"))
1363             svp = &PL_diehook;
1364         else if (strEQ(s,"__WARN__"))
1365             svp = &PL_warnhook;
1366         else
1367             Perl_croak(aTHX_ "No such hook: %s", s);
1368         i = 0;
1369         if (*svp) {
1370             to_dec = *svp;
1371             *svp = 0;
1372         }
1373     }
1374     else {
1375         i = whichsig(s);        /* ...no, a brick */
1376         if (i <= 0) {
1377             if (ckWARN(WARN_SIGNAL))
1378                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1379             return 0;
1380         }
1381 #ifdef HAS_SIGPROCMASK
1382         /* Avoid having the signal arrive at a bad time, if possible. */
1383         sigemptyset(&set);
1384         sigaddset(&set,i);
1385         sigprocmask(SIG_BLOCK, &set, &save);
1386         ENTER;
1387         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1388         SAVEFREESV(save_sv);
1389         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1390 #endif
1391         PERL_ASYNC_CHECK();
1392 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1393         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1394 #endif
1395 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1396         PL_sig_ignoring[i] = 0;
1397 #endif
1398 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1399         PL_sig_defaulting[i] = 0;
1400 #endif
1401         SvREFCNT_dec(PL_psig_name[i]);
1402         to_dec = PL_psig_ptr[i];
1403         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1404         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1405         PL_psig_name[i] = newSVpvn(s, len);
1406         SvREADONLY_on(PL_psig_name[i]);
1407     }
1408     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1409         if (i) {
1410             (void)rsignal(i, PL_csighandlerp);
1411 #ifdef HAS_SIGPROCMASK
1412             LEAVE;
1413 #endif
1414         }
1415         else
1416             *svp = SvREFCNT_inc(sv);
1417         if(to_dec)
1418             SvREFCNT_dec(to_dec);
1419         return 0;
1420     }
1421     s = SvPV_force(sv,len);
1422     if (strEQ(s,"IGNORE")) {
1423         if (i) {
1424 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1425             PL_sig_ignoring[i] = 1;
1426             (void)rsignal(i, PL_csighandlerp);
1427 #else
1428             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1429 #endif
1430         }
1431     }
1432     else if (strEQ(s,"DEFAULT") || !*s) {
1433         if (i)
1434 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1435           {
1436             PL_sig_defaulting[i] = 1;
1437             (void)rsignal(i, PL_csighandlerp);
1438           }
1439 #else
1440             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1441 #endif
1442     }
1443     else {
1444         /*
1445          * We should warn if HINT_STRICT_REFS, but without
1446          * access to a known hint bit in a known OP, we can't
1447          * tell whether HINT_STRICT_REFS is in force or not.
1448          */
1449         if (!strchr(s,':') && !strchr(s,'\''))
1450             sv_insert(sv, 0, 0, "main::", 6);
1451         if (i)
1452             (void)rsignal(i, PL_csighandlerp);
1453         else
1454             *svp = SvREFCNT_inc(sv);
1455     }
1456 #ifdef HAS_SIGPROCMASK
1457     if(i)
1458         LEAVE;
1459 #endif
1460     if(to_dec)
1461         SvREFCNT_dec(to_dec);
1462     return 0;
1463 }
1464 #endif /* !PERL_MICRO */
1465
1466 int
1467 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1468 {
1469     PERL_UNUSED_ARG(sv);
1470     PERL_UNUSED_ARG(mg);
1471     PL_sub_generation++;
1472     return 0;
1473 }
1474
1475 int
1476 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1477 {
1478     PERL_UNUSED_ARG(sv);
1479     PERL_UNUSED_ARG(mg);
1480     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1481     PL_amagic_generation++;
1482
1483     return 0;
1484 }
1485
1486 int
1487 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1488 {
1489     HV * const hv = (HV*)LvTARG(sv);
1490     I32 i = 0;
1491     PERL_UNUSED_ARG(mg);
1492
1493     if (hv) {
1494          (void) hv_iterinit(hv);
1495          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1496              i = HvKEYS(hv);
1497          else {
1498              while (hv_iternext(hv))
1499                  i++;
1500          }
1501     }
1502
1503     sv_setiv(sv, (IV)i);
1504     return 0;
1505 }
1506
1507 int
1508 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1509 {
1510     PERL_UNUSED_ARG(mg);
1511     if (LvTARG(sv)) {
1512         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1513     }
1514     return 0;
1515 }
1516
1517 /* caller is responsible for stack switching/cleanup */
1518 STATIC int
1519 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1520 {
1521     dSP;
1522
1523     PUSHMARK(SP);
1524     EXTEND(SP, n);
1525     PUSHs(SvTIED_obj(sv, mg));
1526     if (n > 1) {
1527         if (mg->mg_ptr) {
1528             if (mg->mg_len >= 0)
1529                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1530             else if (mg->mg_len == HEf_SVKEY)
1531                 PUSHs((SV*)mg->mg_ptr);
1532         }
1533         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1534             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1535         }
1536     }
1537     if (n > 2) {
1538         PUSHs(val);
1539     }
1540     PUTBACK;
1541
1542     return call_method(meth, flags);
1543 }
1544
1545 STATIC int
1546 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1547 {
1548     dVAR; dSP;
1549
1550     ENTER;
1551     SAVETMPS;
1552     PUSHSTACKi(PERLSI_MAGIC);
1553
1554     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1555         sv_setsv(sv, *PL_stack_sp--);
1556     }
1557
1558     POPSTACK;
1559     FREETMPS;
1560     LEAVE;
1561     return 0;
1562 }
1563
1564 int
1565 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1566 {
1567     if (mg->mg_ptr)
1568         mg->mg_flags |= MGf_GSKIP;
1569     magic_methpack(sv,mg,"FETCH");
1570     return 0;
1571 }
1572
1573 int
1574 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1575 {
1576     dVAR; dSP;
1577     ENTER;
1578     PUSHSTACKi(PERLSI_MAGIC);
1579     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1580     POPSTACK;
1581     LEAVE;
1582     return 0;
1583 }
1584
1585 int
1586 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1587 {
1588     return magic_methpack(sv,mg,"DELETE");
1589 }
1590
1591
1592 U32
1593 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1594 {
1595     dVAR; dSP;
1596     U32 retval = 0;
1597
1598     ENTER;
1599     SAVETMPS;
1600     PUSHSTACKi(PERLSI_MAGIC);
1601     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1602         sv = *PL_stack_sp--;
1603         retval = (U32) SvIV(sv)-1;
1604     }
1605     POPSTACK;
1606     FREETMPS;
1607     LEAVE;
1608     return retval;
1609 }
1610
1611 int
1612 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1613 {
1614     dVAR; dSP;
1615
1616     ENTER;
1617     PUSHSTACKi(PERLSI_MAGIC);
1618     PUSHMARK(SP);
1619     XPUSHs(SvTIED_obj(sv, mg));
1620     PUTBACK;
1621     call_method("CLEAR", G_SCALAR|G_DISCARD);
1622     POPSTACK;
1623     LEAVE;
1624
1625     return 0;
1626 }
1627
1628 int
1629 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1630 {
1631     dVAR; dSP;
1632     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1633
1634     ENTER;
1635     SAVETMPS;
1636     PUSHSTACKi(PERLSI_MAGIC);
1637     PUSHMARK(SP);
1638     EXTEND(SP, 2);
1639     PUSHs(SvTIED_obj(sv, mg));
1640     if (SvOK(key))
1641         PUSHs(key);
1642     PUTBACK;
1643
1644     if (call_method(meth, G_SCALAR))
1645         sv_setsv(key, *PL_stack_sp--);
1646
1647     POPSTACK;
1648     FREETMPS;
1649     LEAVE;
1650     return 0;
1651 }
1652
1653 int
1654 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1655 {
1656     return magic_methpack(sv,mg,"EXISTS");
1657 }
1658
1659 SV *
1660 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1661 {
1662     dVAR; dSP;
1663     SV *retval = &PL_sv_undef;
1664     SV * const tied = SvTIED_obj((SV*)hv, mg);
1665     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1666
1667     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1668         SV *key;
1669         if (HvEITER_get(hv))
1670             /* we are in an iteration so the hash cannot be empty */
1671             return &PL_sv_yes;
1672         /* no xhv_eiter so now use FIRSTKEY */
1673         key = sv_newmortal();
1674         magic_nextpack((SV*)hv, mg, key);
1675         HvEITER_set(hv, NULL);     /* need to reset iterator */
1676         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1677     }
1678
1679     /* there is a SCALAR method that we can call */
1680     ENTER;
1681     PUSHSTACKi(PERLSI_MAGIC);
1682     PUSHMARK(SP);
1683     EXTEND(SP, 1);
1684     PUSHs(tied);
1685     PUTBACK;
1686
1687     if (call_method("SCALAR", G_SCALAR))
1688         retval = *PL_stack_sp--;
1689     POPSTACK;
1690     LEAVE;
1691     return retval;
1692 }
1693
1694 int
1695 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1696 {
1697     GV * const gv = PL_DBline;
1698     const I32 i = SvTRUE(sv);
1699     SV ** const svp = av_fetch(GvAV(gv),
1700                      atoi(MgPV_nolen_const(mg)), FALSE);
1701     if (svp && SvIOKp(*svp)) {
1702         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1703         if (o) {
1704             /* set or clear breakpoint in the relevant control op */
1705             if (i)
1706                 o->op_flags |= OPf_SPECIAL;
1707             else
1708                 o->op_flags &= ~OPf_SPECIAL;
1709         }
1710     }
1711     return 0;
1712 }
1713
1714 int
1715 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1716 {
1717     const AV * const obj = (AV*)mg->mg_obj;
1718     if (obj) {
1719         sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1720     } else {
1721         SvOK_off(sv);
1722     }
1723     return 0;
1724 }
1725
1726 int
1727 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1728 {
1729     AV * const obj = (AV*)mg->mg_obj;
1730     if (obj) {
1731         av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1732     } else {
1733         if (ckWARN(WARN_MISC))
1734             Perl_warner(aTHX_ packWARN(WARN_MISC),
1735                         "Attempt to set length of freed array");
1736     }
1737     return 0;
1738 }
1739
1740 int
1741 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1742 {
1743     PERL_UNUSED_ARG(sv);
1744     /* during global destruction, mg_obj may already have been freed */
1745     if (PL_in_clean_all)
1746         return 0;
1747
1748     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1749
1750     if (mg) {
1751         /* arylen scalar holds a pointer back to the array, but doesn't own a
1752            reference. Hence the we (the array) are about to go away with it
1753            still pointing at us. Clear its pointer, else it would be pointing
1754            at free memory. See the comment in sv_magic about reference loops,
1755            and why it can't own a reference to us.  */
1756         mg->mg_obj = 0;
1757     }
1758     return 0;
1759 }
1760
1761 int
1762 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1763 {
1764     SV* const lsv = LvTARG(sv);
1765
1766     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1767         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1768         if (mg && mg->mg_len >= 0) {
1769             I32 i = mg->mg_len;
1770             if (DO_UTF8(lsv))
1771                 sv_pos_b2u(lsv, &i);
1772             sv_setiv(sv, i + PL_curcop->cop_arybase);
1773             return 0;
1774         }
1775     }
1776     SvOK_off(sv);
1777     return 0;
1778 }
1779
1780 int
1781 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1782 {
1783     SV* const lsv = LvTARG(sv);
1784     SSize_t pos;
1785     STRLEN len;
1786     STRLEN ulen = 0;
1787
1788     mg = 0;
1789
1790     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1791         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1792     if (!mg) {
1793         if (!SvOK(sv))
1794             return 0;
1795         sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1796         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1797     }
1798     else if (!SvOK(sv)) {
1799         mg->mg_len = -1;
1800         return 0;
1801     }
1802     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1803
1804     pos = SvIV(sv) - PL_curcop->cop_arybase;
1805
1806     if (DO_UTF8(lsv)) {
1807         ulen = sv_len_utf8(lsv);
1808         if (ulen)
1809             len = ulen;
1810     }
1811
1812     if (pos < 0) {
1813         pos += len;
1814         if (pos < 0)
1815             pos = 0;
1816     }
1817     else if (pos > (SSize_t)len)
1818         pos = len;
1819
1820     if (ulen) {
1821         I32 p = pos;
1822         sv_pos_u2b(lsv, &p, 0);
1823         pos = p;
1824     }
1825
1826     mg->mg_len = pos;
1827     mg->mg_flags &= ~MGf_MINMATCH;
1828
1829     return 0;
1830 }
1831
1832 int
1833 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1834 {
1835     PERL_UNUSED_ARG(mg);
1836     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1837         SvFAKE_off(sv);
1838         gv_efullname3(sv,((GV*)sv), "*");
1839         SvFAKE_on(sv);
1840     }
1841     else
1842         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1843     return 0;
1844 }
1845
1846 int
1847 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1848 {
1849     GV* gv;
1850     PERL_UNUSED_ARG(mg);
1851
1852     if (!SvOK(sv))
1853         return 0;
1854     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1855     if (sv == (SV*)gv)
1856         return 0;
1857     if (GvGP(sv))
1858         gp_free((GV*)sv);
1859     GvGP(sv) = gp_ref(GvGP(gv));
1860     return 0;
1861 }
1862
1863 int
1864 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1865 {
1866     STRLEN len;
1867     SV * const lsv = LvTARG(sv);
1868     const char * const tmps = SvPV_const(lsv,len);
1869     I32 offs = LvTARGOFF(sv);
1870     I32 rem = LvTARGLEN(sv);
1871     PERL_UNUSED_ARG(mg);
1872
1873     if (SvUTF8(lsv))
1874         sv_pos_u2b(lsv, &offs, &rem);
1875     if (offs > (I32)len)
1876         offs = len;
1877     if (rem + offs > (I32)len)
1878         rem = len - offs;
1879     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1880     if (SvUTF8(lsv))
1881         SvUTF8_on(sv);
1882     return 0;
1883 }
1884
1885 int
1886 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1887 {
1888     STRLEN len;
1889     const char *tmps = SvPV_const(sv, len);
1890     SV * const lsv = LvTARG(sv);
1891     I32 lvoff = LvTARGOFF(sv);
1892     I32 lvlen = LvTARGLEN(sv);
1893     PERL_UNUSED_ARG(mg);
1894
1895     if (DO_UTF8(sv)) {
1896         sv_utf8_upgrade(lsv);
1897         sv_pos_u2b(lsv, &lvoff, &lvlen);
1898         sv_insert(lsv, lvoff, lvlen, tmps, len);
1899         LvTARGLEN(sv) = sv_len_utf8(sv);
1900         SvUTF8_on(lsv);
1901     }
1902     else if (lsv && SvUTF8(lsv)) {
1903         sv_pos_u2b(lsv, &lvoff, &lvlen);
1904         LvTARGLEN(sv) = len;
1905         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1906         sv_insert(lsv, lvoff, lvlen, tmps, len);
1907         Safefree(tmps);
1908     }
1909     else {
1910         sv_insert(lsv, lvoff, lvlen, tmps, len);
1911         LvTARGLEN(sv) = len;
1912     }
1913
1914
1915     return 0;
1916 }
1917
1918 int
1919 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1920 {
1921     PERL_UNUSED_ARG(sv);
1922     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1923     return 0;
1924 }
1925
1926 int
1927 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1928 {
1929     PERL_UNUSED_ARG(sv);
1930     /* update taint status unless we're restoring at scope exit */
1931     if (PL_localizing != 2) {
1932         if (PL_tainted)
1933             mg->mg_len |= 1;
1934         else
1935             mg->mg_len &= ~1;
1936     }
1937     return 0;
1938 }
1939
1940 int
1941 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1942 {
1943     SV * const lsv = LvTARG(sv);
1944     PERL_UNUSED_ARG(mg);
1945
1946     if (!lsv) {
1947         SvOK_off(sv);
1948         return 0;
1949     }
1950
1951     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1952     return 0;
1953 }
1954
1955 int
1956 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1957 {
1958     PERL_UNUSED_ARG(mg);
1959     do_vecset(sv);      /* XXX slurp this routine */
1960     return 0;
1961 }
1962
1963 int
1964 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1965 {
1966     SV *targ = Nullsv;
1967     if (LvTARGLEN(sv)) {
1968         if (mg->mg_obj) {
1969             SV * const ahv = LvTARG(sv);
1970             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1971             if (he)
1972                 targ = HeVAL(he);
1973         }
1974         else {
1975             AV* const av = (AV*)LvTARG(sv);
1976             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1977                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1978         }
1979         if (targ && targ != &PL_sv_undef) {
1980             /* somebody else defined it for us */
1981             SvREFCNT_dec(LvTARG(sv));
1982             LvTARG(sv) = SvREFCNT_inc(targ);
1983             LvTARGLEN(sv) = 0;
1984             SvREFCNT_dec(mg->mg_obj);
1985             mg->mg_obj = Nullsv;
1986             mg->mg_flags &= ~MGf_REFCOUNTED;
1987         }
1988     }
1989     else
1990         targ = LvTARG(sv);
1991     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1992     return 0;
1993 }
1994
1995 int
1996 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1997 {
1998     PERL_UNUSED_ARG(mg);
1999     if (LvTARGLEN(sv))
2000         vivify_defelem(sv);
2001     if (LvTARG(sv)) {
2002         sv_setsv(LvTARG(sv), sv);
2003         SvSETMAGIC(LvTARG(sv));
2004     }
2005     return 0;
2006 }
2007
2008 void
2009 Perl_vivify_defelem(pTHX_ SV *sv)
2010 {
2011     MAGIC *mg;
2012     SV *value = Nullsv;
2013
2014     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2015         return;
2016     if (mg->mg_obj) {
2017         SV * const ahv = LvTARG(sv);
2018         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2019         if (he)
2020             value = HeVAL(he);
2021         if (!value || value == &PL_sv_undef)
2022             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2023     }
2024     else {
2025         AV* const av = (AV*)LvTARG(sv);
2026         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2027             LvTARG(sv) = Nullsv;        /* array can't be extended */
2028         else {
2029             SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2030             if (!svp || (value = *svp) == &PL_sv_undef)
2031                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2032         }
2033     }
2034     (void)SvREFCNT_inc(value);
2035     SvREFCNT_dec(LvTARG(sv));
2036     LvTARG(sv) = value;
2037     LvTARGLEN(sv) = 0;
2038     SvREFCNT_dec(mg->mg_obj);
2039     mg->mg_obj = Nullsv;
2040     mg->mg_flags &= ~MGf_REFCOUNTED;
2041 }
2042
2043 int
2044 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2045 {
2046     AV *const av = (AV*)mg->mg_obj;
2047     SV **svp = AvARRAY(av);
2048     PERL_UNUSED_ARG(sv);
2049
2050     /* Not sure why the av can get freed ahead of its sv, but somehow it does
2051        in ext/B/t/bytecode.t test 15 (involving print <DATA>)  */
2052     if (svp && !SvIS_FREED(av)) {
2053         SV *const *const last = svp + AvFILLp(av);
2054
2055         while (svp <= last) {
2056             if (*svp) {
2057                 SV *const referrer = *svp;
2058                 if (SvWEAKREF(referrer)) {
2059                     /* XXX Should we check that it hasn't changed? */
2060                     SvRV_set(referrer, 0);
2061                     SvOK_off(referrer);
2062                     SvWEAKREF_off(referrer);
2063                 } else if (SvTYPE(referrer) == SVt_PVGV ||
2064                            SvTYPE(referrer) == SVt_PVLV) {
2065                     /* You lookin' at me?  */
2066                     assert(GvSTASH(referrer));
2067                     assert(GvSTASH(referrer) == (HV*)sv);
2068                     GvSTASH(referrer) = 0;
2069                 } else {
2070                     Perl_croak(aTHX_
2071                                "panic: magic_killbackrefs (flags=%"UVxf")",
2072                                (UV)SvFLAGS(referrer));
2073                 }
2074
2075                 *svp = Nullsv;
2076             }
2077             svp++;
2078         }
2079     }
2080     SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
2081     return 0;
2082 }
2083
2084 int
2085 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2086 {
2087     mg->mg_len = -1;
2088     SvSCREAM_off(sv);
2089     return 0;
2090 }
2091
2092 int
2093 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2094 {
2095     PERL_UNUSED_ARG(mg);
2096     sv_unmagic(sv, PERL_MAGIC_bm);
2097     SvVALID_off(sv);
2098     return 0;
2099 }
2100
2101 int
2102 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2103 {
2104     PERL_UNUSED_ARG(mg);
2105     sv_unmagic(sv, PERL_MAGIC_fm);
2106     SvCOMPILED_off(sv);
2107     return 0;
2108 }
2109
2110 int
2111 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2112 {
2113     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2114
2115     if (uf && uf->uf_set)
2116         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2117     return 0;
2118 }
2119
2120 int
2121 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2122 {
2123     PERL_UNUSED_ARG(mg);
2124     sv_unmagic(sv, PERL_MAGIC_qr);
2125     return 0;
2126 }
2127
2128 int
2129 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2130 {
2131     regexp * const re = (regexp *)mg->mg_obj;
2132     PERL_UNUSED_ARG(sv);
2133
2134     ReREFCNT_dec(re);
2135     return 0;
2136 }
2137
2138 #ifdef USE_LOCALE_COLLATE
2139 int
2140 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2141 {
2142     /*
2143      * RenE<eacute> Descartes said "I think not."
2144      * and vanished with a faint plop.
2145      */
2146     PERL_UNUSED_ARG(sv);
2147     if (mg->mg_ptr) {
2148         Safefree(mg->mg_ptr);
2149         mg->mg_ptr = NULL;
2150         mg->mg_len = -1;
2151     }
2152     return 0;
2153 }
2154 #endif /* USE_LOCALE_COLLATE */
2155
2156 /* Just clear the UTF-8 cache data. */
2157 int
2158 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2159 {
2160     PERL_UNUSED_ARG(sv);
2161     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2162     mg->mg_ptr = 0;
2163     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2164     return 0;
2165 }
2166
2167 int
2168 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2169 {
2170     register const char *s;
2171     I32 i;
2172     STRLEN len;
2173     switch (*mg->mg_ptr) {
2174     case '\001':        /* ^A */
2175         sv_setsv(PL_bodytarget, sv);
2176         break;
2177     case '\003':        /* ^C */
2178         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2179         break;
2180
2181     case '\004':        /* ^D */
2182 #ifdef DEBUGGING
2183         s = SvPV_nolen_const(sv);
2184         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2185         DEBUG_x(dump_all());
2186 #else
2187         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
2188 #endif
2189         break;
2190     case '\005':  /* ^E */
2191         if (*(mg->mg_ptr+1) == '\0') {
2192 #ifdef MACOS_TRADITIONAL
2193             gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2194 #else
2195 #  ifdef VMS
2196             set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2197 #  else
2198 #    ifdef WIN32
2199             SetLastError( SvIV(sv) );
2200 #    else
2201 #      ifdef OS2
2202             os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2203 #      else
2204             /* will anyone ever use this? */
2205             SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
2206 #      endif
2207 #    endif
2208 #  endif
2209 #endif
2210         }
2211         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2212             if (PL_encoding)
2213                 SvREFCNT_dec(PL_encoding);
2214             if (SvOK(sv) || SvGMAGICAL(sv)) {
2215                 PL_encoding = newSVsv(sv);
2216             }
2217             else {
2218                 PL_encoding = Nullsv;
2219             }
2220         }
2221         break;
2222     case '\006':        /* ^F */
2223         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2224         break;
2225     case '\010':        /* ^H */
2226         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2227         break;
2228     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2229         Safefree(PL_inplace);
2230         PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
2231         break;
2232     case '\017':        /* ^O */
2233         if (*(mg->mg_ptr+1) == '\0') {
2234             Safefree(PL_osname);
2235             PL_osname = Nullch;
2236             if (SvOK(sv)) {
2237                 TAINT_PROPER("assigning to $^O");
2238                 PL_osname = savesvpv(sv);
2239             }
2240         }
2241         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2242             if (!PL_compiling.cop_io)
2243                 PL_compiling.cop_io = newSVsv(sv);
2244             else
2245                 sv_setsv(PL_compiling.cop_io,sv);
2246         }
2247         break;
2248     case '\020':        /* ^P */
2249         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2250         if (PL_perldb && !PL_DBsingle)
2251             init_debugger();
2252         break;
2253     case '\024':        /* ^T */
2254 #ifdef BIG_TIME
2255         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2256 #else
2257         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2258 #endif
2259         break;
2260     case '\027':        /* ^W & $^WARNING_BITS */
2261         if (*(mg->mg_ptr+1) == '\0') {
2262             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2263                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2264                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2265                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2266             }
2267         }
2268         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2269             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2270                 if (!SvPOK(sv) && PL_localizing) {
2271                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2272                     PL_compiling.cop_warnings = pWARN_NONE;
2273                     break;
2274                 }
2275                 {
2276                     STRLEN len, i;
2277                     int accumulate = 0 ;
2278                     int any_fatals = 0 ;
2279                     const char * const ptr = SvPV_const(sv, len) ;
2280                     for (i = 0 ; i < len ; ++i) {
2281                         accumulate |= ptr[i] ;
2282                         any_fatals |= (ptr[i] & 0xAA) ;
2283                     }
2284                     if (!accumulate)
2285                         PL_compiling.cop_warnings = pWARN_NONE;
2286                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
2287                         PL_compiling.cop_warnings = pWARN_ALL;
2288                         PL_dowarn |= G_WARN_ONCE ;
2289                     }
2290                     else {
2291                         if (specialWARN(PL_compiling.cop_warnings))
2292                             PL_compiling.cop_warnings = newSVsv(sv) ;
2293                         else
2294                             sv_setsv(PL_compiling.cop_warnings, sv);
2295                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2296                             PL_dowarn |= G_WARN_ONCE ;
2297                     }
2298
2299                 }
2300             }
2301         }
2302         break;
2303     case '.':
2304         if (PL_localizing) {
2305             if (PL_localizing == 1)
2306                 SAVESPTR(PL_last_in_gv);
2307         }
2308         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2309             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2310         break;
2311     case '^':
2312         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2313         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2314         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2315         break;
2316     case '~':
2317         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2318         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2319         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2320         break;
2321     case '=':
2322         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2323         break;
2324     case '-':
2325         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2326         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2327             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2328         break;
2329     case '%':
2330         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2331         break;
2332     case '|':
2333         {
2334             IO * const io = GvIOp(PL_defoutgv);
2335             if(!io)
2336               break;
2337             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2338                 IoFLAGS(io) &= ~IOf_FLUSH;
2339             else {
2340                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2341                     PerlIO *ofp = IoOFP(io);
2342                     if (ofp)
2343                         (void)PerlIO_flush(ofp);
2344                     IoFLAGS(io) |= IOf_FLUSH;
2345                 }
2346             }
2347         }
2348         break;
2349     case '/':
2350         SvREFCNT_dec(PL_rs);
2351         PL_rs = newSVsv(sv);
2352         break;
2353     case '\\':
2354         if (PL_ors_sv)
2355             SvREFCNT_dec(PL_ors_sv);
2356         if (SvOK(sv) || SvGMAGICAL(sv)) {
2357             PL_ors_sv = newSVsv(sv);
2358         }
2359         else {
2360             PL_ors_sv = Nullsv;
2361         }
2362         break;
2363     case ',':
2364         if (PL_ofs_sv)
2365             SvREFCNT_dec(PL_ofs_sv);
2366         if (SvOK(sv) || SvGMAGICAL(sv)) {
2367             PL_ofs_sv = newSVsv(sv);
2368         }
2369         else {
2370             PL_ofs_sv = Nullsv;
2371         }
2372         break;
2373     case '[':
2374         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2375         break;
2376     case '?':
2377 #ifdef COMPLEX_STATUS
2378         if (PL_localizing == 2) {
2379             PL_statusvalue = LvTARGOFF(sv);
2380             PL_statusvalue_vms = LvTARGLEN(sv);
2381         }
2382         else
2383 #endif
2384 #ifdef VMSISH_STATUS
2385         if (VMSISH_STATUS)
2386             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2387         else
2388 #endif
2389             STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2390         break;
2391     case '!':
2392         {
2393 #ifdef VMS
2394 #   define PERL_VMS_BANG vaxc$errno
2395 #else
2396 #   define PERL_VMS_BANG 0
2397 #endif
2398         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2399                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2400         }
2401         break;
2402     case '<':
2403         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2404         if (PL_delaymagic) {
2405             PL_delaymagic |= DM_RUID;
2406             break;                              /* don't do magic till later */
2407         }
2408 #ifdef HAS_SETRUID
2409         (void)setruid((Uid_t)PL_uid);
2410 #else
2411 #ifdef HAS_SETREUID
2412         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2413 #else
2414 #ifdef HAS_SETRESUID
2415       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2416 #else
2417         if (PL_uid == PL_euid) {                /* special case $< = $> */
2418 #ifdef PERL_DARWIN
2419             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2420             if (PL_uid != 0 && PerlProc_getuid() == 0)
2421                 (void)PerlProc_setuid(0);
2422 #endif
2423             (void)PerlProc_setuid(PL_uid);
2424         } else {
2425             PL_uid = PerlProc_getuid();
2426             Perl_croak(aTHX_ "setruid() not implemented");
2427         }
2428 #endif
2429 #endif
2430 #endif
2431         PL_uid = PerlProc_getuid();
2432         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2433         break;
2434     case '>':
2435         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2436         if (PL_delaymagic) {
2437             PL_delaymagic |= DM_EUID;
2438             break;                              /* don't do magic till later */
2439         }
2440 #ifdef HAS_SETEUID
2441         (void)seteuid((Uid_t)PL_euid);
2442 #else
2443 #ifdef HAS_SETREUID
2444         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2445 #else
2446 #ifdef HAS_SETRESUID
2447         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2448 #else
2449         if (PL_euid == PL_uid)          /* special case $> = $< */
2450             PerlProc_setuid(PL_euid);
2451         else {
2452             PL_euid = PerlProc_geteuid();
2453             Perl_croak(aTHX_ "seteuid() not implemented");
2454         }
2455 #endif
2456 #endif
2457 #endif
2458         PL_euid = PerlProc_geteuid();
2459         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2460         break;
2461     case '(':
2462         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2463         if (PL_delaymagic) {
2464             PL_delaymagic |= DM_RGID;
2465             break;                              /* don't do magic till later */
2466         }
2467 #ifdef HAS_SETRGID
2468         (void)setrgid((Gid_t)PL_gid);
2469 #else
2470 #ifdef HAS_SETREGID
2471         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2472 #else
2473 #ifdef HAS_SETRESGID
2474       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2475 #else
2476         if (PL_gid == PL_egid)                  /* special case $( = $) */
2477             (void)PerlProc_setgid(PL_gid);
2478         else {
2479             PL_gid = PerlProc_getgid();
2480             Perl_croak(aTHX_ "setrgid() not implemented");
2481         }
2482 #endif
2483 #endif
2484 #endif
2485         PL_gid = PerlProc_getgid();
2486         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2487         break;
2488     case ')':
2489 #ifdef HAS_SETGROUPS
2490         {
2491             const char *p = SvPV_const(sv, len);
2492             Groups_t gary[NGROUPS];
2493
2494             while (isSPACE(*p))
2495                 ++p;
2496             PL_egid = Atol(p);
2497             for (i = 0; i < NGROUPS; ++i) {
2498                 while (*p && !isSPACE(*p))
2499                     ++p;
2500                 while (isSPACE(*p))
2501                     ++p;
2502                 if (!*p)
2503                     break;
2504                 gary[i] = Atol(p);
2505             }
2506             if (i)
2507                 (void)setgroups(i, gary);
2508         }
2509 #else  /* HAS_SETGROUPS */
2510         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2511 #endif /* HAS_SETGROUPS */
2512         if (PL_delaymagic) {
2513             PL_delaymagic |= DM_EGID;
2514             break;                              /* don't do magic till later */
2515         }
2516 #ifdef HAS_SETEGID
2517         (void)setegid((Gid_t)PL_egid);
2518 #else
2519 #ifdef HAS_SETREGID
2520         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2521 #else
2522 #ifdef HAS_SETRESGID
2523         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2524 #else
2525         if (PL_egid == PL_gid)                  /* special case $) = $( */
2526             (void)PerlProc_setgid(PL_egid);
2527         else {
2528             PL_egid = PerlProc_getegid();
2529             Perl_croak(aTHX_ "setegid() not implemented");
2530         }
2531 #endif
2532 #endif
2533 #endif
2534         PL_egid = PerlProc_getegid();
2535         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2536         break;
2537     case ':':
2538         PL_chopset = SvPV_force(sv,len);
2539         break;
2540 #ifndef MACOS_TRADITIONAL
2541     case '0':
2542         LOCK_DOLLARZERO_MUTEX;
2543 #ifdef HAS_SETPROCTITLE
2544         /* The BSDs don't show the argv[] in ps(1) output, they
2545          * show a string from the process struct and provide
2546          * the setproctitle() routine to manipulate that. */
2547         {
2548             s = SvPV_const(sv, len);
2549 #   if __FreeBSD_version > 410001
2550             /* The leading "-" removes the "perl: " prefix,
2551              * but not the "(perl) suffix from the ps(1)
2552              * output, because that's what ps(1) shows if the
2553              * argv[] is modified. */
2554             setproctitle("-%s", s);
2555 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2556             /* This doesn't really work if you assume that
2557              * $0 = 'foobar'; will wipe out 'perl' from the $0
2558              * because in ps(1) output the result will be like
2559              * sprintf("perl: %s (perl)", s)
2560              * I guess this is a security feature:
2561              * one (a user process) cannot get rid of the original name.
2562              * --jhi */
2563             setproctitle("%s", s);
2564 #   endif
2565         }
2566 #endif
2567 #if defined(__hpux) && defined(PSTAT_SETCMD)
2568         {
2569              union pstun un;
2570              s = SvPV_const(sv, len);
2571              un.pst_command = (char *)s;
2572              pstat(PSTAT_SETCMD, un, len, 0, 0);
2573         }
2574 #endif
2575         /* PL_origalen is set in perl_parse(). */
2576         s = SvPV_force(sv,len);
2577         if (len >= (STRLEN)PL_origalen-1) {
2578             /* Longer than original, will be truncated. We assume that
2579              * PL_origalen bytes are available. */
2580             Copy(s, PL_origargv[0], PL_origalen-1, char);
2581         }
2582         else {
2583             /* Shorter than original, will be padded. */
2584             Copy(s, PL_origargv[0], len, char);
2585             PL_origargv[0][len] = 0;
2586             memset(PL_origargv[0] + len + 1,
2587                    /* Is the space counterintuitive?  Yes.
2588                     * (You were expecting \0?)
2589                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2590                     * --jhi */
2591                    (int)' ',
2592                    PL_origalen - len - 1);
2593         }
2594         PL_origargv[0][PL_origalen-1] = 0;
2595         for (i = 1; i < PL_origargc; i++)
2596             PL_origargv[i] = 0;
2597         UNLOCK_DOLLARZERO_MUTEX;
2598         break;
2599 #endif
2600     }
2601     return 0;
2602 }
2603
2604 I32
2605 Perl_whichsig(pTHX_ const char *sig)
2606 {
2607     register char* const* sigv;
2608
2609     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2610         if (strEQ(sig,*sigv))
2611             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2612 #ifdef SIGCLD
2613     if (strEQ(sig,"CHLD"))
2614         return SIGCLD;
2615 #endif
2616 #ifdef SIGCHLD
2617     if (strEQ(sig,"CLD"))
2618         return SIGCHLD;
2619 #endif
2620     return -1;
2621 }
2622
2623 Signal_t
2624 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2625 Perl_sighandler(int sig, ...)
2626 #else
2627 Perl_sighandler(int sig)
2628 #endif
2629 {
2630 #ifdef PERL_GET_SIG_CONTEXT
2631     dTHXa(PERL_GET_SIG_CONTEXT);
2632 #else
2633     dTHX;
2634 #endif
2635     dSP;
2636     GV *gv = Nullgv;
2637     SV *sv = Nullsv;
2638     SV * const tSv = PL_Sv;
2639     CV *cv = Nullcv;
2640     OP *myop = PL_op;
2641     U32 flags = 0;
2642     XPV * const tXpv = PL_Xpv;
2643
2644     if (PL_savestack_ix + 15 <= PL_savestack_max)
2645         flags |= 1;
2646     if (PL_markstack_ptr < PL_markstack_max - 2)
2647         flags |= 4;
2648     if (PL_scopestack_ix < PL_scopestack_max - 3)
2649         flags |= 16;
2650
2651     if (!PL_psig_ptr[sig]) {
2652                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2653                                  PL_sig_name[sig]);
2654                 exit(sig);
2655         }
2656
2657     /* Max number of items pushed there is 3*n or 4. We cannot fix
2658        infinity, so we fix 4 (in fact 5): */
2659     if (flags & 1) {
2660         PL_savestack_ix += 5;           /* Protect save in progress. */
2661         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2662     }
2663     if (flags & 4)
2664         PL_markstack_ptr++;             /* Protect mark. */
2665     if (flags & 16)
2666         PL_scopestack_ix += 1;
2667     /* sv_2cv is too complicated, try a simpler variant first: */
2668     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2669         || SvTYPE(cv) != SVt_PVCV) {
2670         HV *st;
2671         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2672     }
2673
2674     if (!cv || !CvROOT(cv)) {
2675         if (ckWARN(WARN_SIGNAL))
2676             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2677                 PL_sig_name[sig], (gv ? GvENAME(gv)
2678                                 : ((cv && CvGV(cv))
2679                                    ? GvENAME(CvGV(cv))
2680                                    : "__ANON__")));
2681         goto cleanup;
2682     }
2683
2684     if(PL_psig_name[sig]) {
2685         sv = SvREFCNT_inc(PL_psig_name[sig]);
2686         flags |= 64;
2687 #if !defined(PERL_IMPLICIT_CONTEXT)
2688         PL_sig_sv = sv;
2689 #endif
2690     } else {
2691         sv = sv_newmortal();
2692         sv_setpv(sv,PL_sig_name[sig]);
2693     }
2694
2695     PUSHSTACKi(PERLSI_SIGNAL);
2696     PUSHMARK(SP);
2697     PUSHs(sv);
2698 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2699     {
2700          struct sigaction oact;
2701
2702          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2703               siginfo_t *sip;
2704               va_list args;
2705
2706               va_start(args, sig);
2707               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2708               if (sip) {
2709                    HV *sih = newHV();
2710                    SV *rv  = newRV_noinc((SV*)sih);
2711                    /* The siginfo fields signo, code, errno, pid, uid,
2712                     * addr, status, and band are defined by POSIX/SUSv3. */
2713                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2714                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2715 #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. */
2716                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2717                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2718                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2719                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2720                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2721                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2722 #endif
2723                    EXTEND(SP, 2);
2724                    PUSHs((SV*)rv);
2725                    PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2726               }
2727
2728               va_end(args);
2729          }
2730     }
2731 #endif
2732     PUTBACK;
2733
2734     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2735
2736     POPSTACK;
2737     if (SvTRUE(ERRSV)) {
2738 #ifndef PERL_MICRO
2739 #ifdef HAS_SIGPROCMASK
2740         /* Handler "died", for example to get out of a restart-able read().
2741          * Before we re-do that on its behalf re-enable the signal which was
2742          * blocked by the system when we entered.
2743          */
2744         sigset_t set;
2745         sigemptyset(&set);
2746         sigaddset(&set,sig);
2747         sigprocmask(SIG_UNBLOCK, &set, NULL);
2748 #else
2749         /* Not clear if this will work */
2750         (void)rsignal(sig, SIG_IGN);
2751         (void)rsignal(sig, PL_csighandlerp);
2752 #endif
2753 #endif /* !PERL_MICRO */
2754         Perl_die(aTHX_ Nullch);
2755     }
2756 cleanup:
2757     if (flags & 1)
2758         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2759     if (flags & 4)
2760         PL_markstack_ptr--;
2761     if (flags & 16)
2762         PL_scopestack_ix -= 1;
2763     if (flags & 64)
2764         SvREFCNT_dec(sv);
2765     PL_op = myop;                       /* Apparently not needed... */
2766
2767     PL_Sv = tSv;                        /* Restore global temporaries. */
2768     PL_Xpv = tXpv;
2769     return;
2770 }
2771
2772
2773 static void
2774 S_restore_magic(pTHX_ const void *p)
2775 {
2776     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2777     SV* const sv = mgs->mgs_sv;
2778
2779     if (!sv)
2780         return;
2781
2782     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2783     {
2784 #ifdef PERL_OLD_COPY_ON_WRITE
2785         /* While magic was saved (and off) sv_setsv may well have seen
2786            this SV as a prime candidate for COW.  */
2787         if (SvIsCOW(sv))
2788             sv_force_normal_flags(sv, 0);
2789 #endif
2790
2791         if (mgs->mgs_flags)
2792             SvFLAGS(sv) |= mgs->mgs_flags;
2793         else
2794             mg_magical(sv);
2795         if (SvGMAGICAL(sv)) {
2796             /* downgrade public flags to private,
2797                and discard any other private flags */
2798
2799             U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2800             if (public) {
2801                 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2802                 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2803             }
2804         }
2805     }
2806
2807     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2808
2809     /* If we're still on top of the stack, pop us off.  (That condition
2810      * will be satisfied if restore_magic was called explicitly, but *not*
2811      * if it's being called via leave_scope.)
2812      * The reason for doing this is that otherwise, things like sv_2cv()
2813      * may leave alloc gunk on the savestack, and some code
2814      * (e.g. sighandler) doesn't expect that...
2815      */
2816     if (PL_savestack_ix == mgs->mgs_ss_ix)
2817     {
2818         I32 popval = SSPOPINT;
2819         assert(popval == SAVEt_DESTRUCTOR_X);
2820         PL_savestack_ix -= 2;
2821         popval = SSPOPINT;
2822         assert(popval == SAVEt_ALLOC);
2823         popval = SSPOPINT;
2824         PL_savestack_ix -= popval;
2825     }
2826
2827 }
2828
2829 static void
2830 S_unwind_handler_stack(pTHX_ const void *p)
2831 {
2832     dVAR;
2833     const U32 flags = *(const U32*)p;
2834
2835     if (flags & 1)
2836         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2837     /* cxstack_ix-- Not needed, die already unwound it. */
2838 #if !defined(PERL_IMPLICIT_CONTEXT)
2839     if (flags & 64)
2840         SvREFCNT_dec(PL_sig_sv);
2841 #endif
2842 }
2843
2844 /*
2845  * Local variables:
2846  * c-indentation-style: bsd
2847  * c-basic-offset: 4
2848  * indent-tabs-mode: t
2849  * End:
2850  *
2851  * ex: set ts=8 sts=4 sw=4 noet:
2852  */