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, 2006, 2007, 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 #  ifdef I_GRP
  44 #    include <grp.h>
  45 #  endif
  46 #endif
  47
  48 #if defined(HAS_SETGROUPS)
  49 #  ifndef NGROUPS
  50 #    define NGROUPS 32
  51 #  endif
  52 #endif
  53
  54 #ifdef __hpux
  55 #  include <sys/pstat.h>
  56 #endif
  57
  58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
  59 Signal_t Perl_csighandler(int sig, ...);
  60 #else
  61 Signal_t Perl_csighandler(int sig);
  62 #endif
  63
  64 #ifdef __Lynx__
  65 /* Missing protos on LynxOS */
  66 void setruid(uid_t id);
  67 void seteuid(uid_t id);
  68 void setrgid(uid_t id);
  69 void setegid(uid_t id);
  70 #endif
  71
  72 /*
  73  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  74  */
  75
  76 struct magic_state {
  77     SV* mgs_sv;
  78     U32 mgs_flags;
  79     I32 mgs_ss_ix;
  80 };
  81 /* MGS is typedef'ed to struct magic_state in perl.h */
  82
  83 STATIC void
  84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
  85 {
  86     dVAR;
  87     MGS* mgs;
  88     assert(SvMAGICAL(sv));
  89     /* Turning READONLY off for a copy-on-write scalar (including shared
  90        hash keys) is a bad idea.  */
  91     if (SvIsCOW(sv))
  92       sv_force_normal_flags(sv, 0);
  93
  94     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
  95
  96     mgs = SSPTR(mgs_ix, MGS*);
  97     mgs->mgs_sv = sv;
  98     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  99     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
 100
 101     SvMAGICAL_off(sv);
 102     SvREADONLY_off(sv);
 103     if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
 104         /* No public flags are set, so promote any private flags to public.  */
 105         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 106     }
 107 }
 108
 109 /*
 110 =for apidoc mg_magical
 111
 112 Turns on the magical status of an SV.  See C<sv_magic>.
 113
 114 =cut
 115 */
 116
 117 void
 118 Perl_mg_magical(pTHX_ SV *sv)
 119 {
 120     const MAGIC* mg;
 121     PERL_UNUSED_CONTEXT;
 122     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 123         const MGVTBL* const vtbl = mg->mg_virtual;
 124         if (vtbl) {
 125             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 126                 SvGMAGICAL_on(sv);
 127             if (vtbl->svt_set)
 128                 SvSMAGICAL_on(sv);
 129             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
 130                 SvRMAGICAL_on(sv);
 131         }
 132     }
 133 }
 134
 135 /*
 136 =for apidoc mg_get
 137
 138 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 139
 140 =cut
 141 */
 142
 143 int
 144 Perl_mg_get(pTHX_ SV *sv)
 145 {
 146     dVAR;
 147     const I32 mgs_ix = SSNEW(sizeof(MGS));
 148     const bool was_temp = (bool)SvTEMP(sv);
 149     int have_new = 0;
 150     MAGIC *newmg, *head, *cur, *mg;
 151     /* guard against sv having being freed midway by holding a private
 152        reference. */
 153
 154     /* sv_2mortal has this side effect of turning on the TEMP flag, which can
 155        cause the SV's buffer to get stolen (and maybe other stuff).
 156        So restore it.
 157     */
 158     sv_2mortal(SvREFCNT_inc_simple_NN(sv));
 159     if (!was_temp) {
 160         SvTEMP_off(sv);
 161     }
 162
 163     save_magic(mgs_ix, sv);
 164
 165     /* We must call svt_get(sv, mg) for each valid entry in the linked
 166        list of magic. svt_get() may delete the current entry, add new
 167        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 168
 169     newmg = cur = head = mg = SvMAGIC(sv);
 170     while (mg) {
 171         const MGVTBL * const vtbl = mg->mg_virtual;
 172
 173         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 174             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 175
 176             /* guard against magic having been deleted - eg FETCH calling
 177              * untie */
 178             if (!SvMAGIC(sv))
 179                 break;
 180
 181             /* Don't restore the flags for this entry if it was deleted. */
 182             if (mg->mg_flags & MGf_GSKIP)
 183                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
 184         }
 185
 186         mg = mg->mg_moremagic;
 187
 188         if (have_new) {
 189             /* Have we finished with the new entries we saw? Start again
 190                where we left off (unless there are more new entries). */
 191             if (mg == head) {
 192                 have_new = 0;
 193                 mg   = cur;
 194                 head = newmg;
 195             }
 196         }
 197
 198         /* Were any new entries added? */
 199         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
 200             have_new = 1;
 201             cur = mg;
 202             mg  = newmg;
 203         }
 204     }
 205
 206     restore_magic(INT2PTR(void *, (IV)mgs_ix));
 207
 208     if (SvREFCNT(sv) == 1) {
 209         /* We hold the last reference to this SV, which implies that the
 210            SV was deleted as a side effect of the routines we called.  */
 211         SvOK_off(sv);
 212     }
 213     return 0;
 214 }
 215
 216 /*
 217 =for apidoc mg_set
 218
 219 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 220
 221 =cut
 222 */
 223
 224 int
 225 Perl_mg_set(pTHX_ SV *sv)
 226 {
 227     dVAR;
 228     const I32 mgs_ix = SSNEW(sizeof(MGS));
 229     MAGIC* mg;
 230     MAGIC* nextmg;
 231
 232     save_magic(mgs_ix, sv);
 233
 234     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 235         const MGVTBL* vtbl = mg->mg_virtual;
 236         nextmg = mg->mg_moremagic;      /* it may delete itself */
 237         if (mg->mg_flags & MGf_GSKIP) {
 238             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 239             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
 240         }
 241         if (vtbl && vtbl->svt_set)
 242             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
 243     }
 244
 245     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 246     return 0;
 247 }
 248
 249 /*
 250 =for apidoc mg_length
 251
 252 Report on the SV's length.  See C<sv_magic>.
 253
 254 =cut
 255 */
 256
 257 U32
 258 Perl_mg_length(pTHX_ SV *sv)
 259 {
 260     dVAR;
 261     MAGIC* mg;
 262     STRLEN len;
 263
 264     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 265         const MGVTBL * const vtbl = mg->mg_virtual;
 266         if (vtbl && vtbl->svt_len) {
 267             const I32 mgs_ix = SSNEW(sizeof(MGS));
 268             save_magic(mgs_ix, sv);
 269             /* omit MGf_GSKIP -- not changed here */
 270             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 271             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 272             return len;
 273         }
 274     }
 275
 276     if (DO_UTF8(sv)) {
 277         const U8 *s = (U8*)SvPV_const(sv, len);
 278         len = utf8_length(s, s + len);
 279     }
 280     else
 281         (void)SvPV_const(sv, len);
 282     return len;
 283 }
 284
 285 I32
 286 Perl_mg_size(pTHX_ SV *sv)
 287 {
 288     MAGIC* mg;
 289
 290     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 291         const MGVTBL* const vtbl = mg->mg_virtual;
 292         if (vtbl && vtbl->svt_len) {
 293             const I32 mgs_ix = SSNEW(sizeof(MGS));
 294             I32 len;
 295             save_magic(mgs_ix, sv);
 296             /* omit MGf_GSKIP -- not changed here */
 297             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 298             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 299             return len;
 300         }
 301     }
 302
 303     switch(SvTYPE(sv)) {
 304         case SVt_PVAV:
 305             return AvFILLp((AV *) sv); /* Fallback to non-tied array */
 306         case SVt_PVHV:
 307             /* FIXME */
 308         default:
 309             Perl_croak(aTHX_ "Size magic not implemented");
 310             break;
 311     }
 312     return 0;
 313 }
 314
 315 /*
 316 =for apidoc mg_clear
 317
 318 Clear something magical that the SV represents.  See C<sv_magic>.
 319
 320 =cut
 321 */
 322
 323 int
 324 Perl_mg_clear(pTHX_ SV *sv)
 325 {
 326     const I32 mgs_ix = SSNEW(sizeof(MGS));
 327     MAGIC* mg;
 328
 329     save_magic(mgs_ix, sv);
 330
 331     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 332         const MGVTBL* const vtbl = mg->mg_virtual;
 333         /* omit GSKIP -- never set here */
 334
 335         if (vtbl && vtbl->svt_clear)
 336             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 337     }
 338
 339     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 340     return 0;
 341 }
 342
 343 /*
 344 =for apidoc mg_find
 345
 346 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 347
 348 =cut
 349 */
 350
 351 MAGIC*
 352 Perl_mg_find(pTHX_ const SV *sv, int type)
 353 {
 354     PERL_UNUSED_CONTEXT;
 355     if (sv) {
 356         MAGIC *mg;
 357         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 358             if (mg->mg_type == type)
 359                 return mg;
 360         }
 361     }
 362     return NULL;
 363 }
 364
 365 /*
 366 =for apidoc mg_copy
 367
 368 Copies the magic from one SV to another.  See C<sv_magic>.
 369
 370 =cut
 371 */
 372
 373 int
 374 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 375 {
 376     int count = 0;
 377     MAGIC* mg;
 378     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 379         const MGVTBL* const vtbl = mg->mg_virtual;
 380         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 381             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 382         }
 383         else {
 384             const char type = mg->mg_type;
 385             if (isUPPER(type) && type != PERL_MAGIC_uvar) {
 386                 sv_magic(nsv,
 387                      (type == PERL_MAGIC_tied)
 388                         ? SvTIED_obj(sv, mg)
 389                         : (type == PERL_MAGIC_regdata && mg->mg_obj)
 390                             ? sv
 391                             : mg->mg_obj,
 392                      toLOWER(type), key, klen);
 393                 count++;
 394             }
 395         }
 396     }
 397     return count;
 398 }
 399
 400 /*
 401 =for apidoc mg_localize
 402
 403 Copy some of the magic from an existing SV to new localized version of
 404 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
 405 doesn't (eg taint, pos).
 406
 407 =cut
 408 */
 409
 410 void
 411 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
 412 {
 413     dVAR;
 414     MAGIC *mg;
 415     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 416         const MGVTBL* const vtbl = mg->mg_virtual;
 417         switch (mg->mg_type) {
 418         /* value magic types: don't copy */
 419         case PERL_MAGIC_bm:
 420         case PERL_MAGIC_fm:
 421         case PERL_MAGIC_regex_global:
 422         case PERL_MAGIC_nkeys:
 423 #ifdef USE_LOCALE_COLLATE
 424         case PERL_MAGIC_collxfrm:
 425 #endif
 426         case PERL_MAGIC_qr:
 427         case PERL_MAGIC_taint:
 428         case PERL_MAGIC_vec:
 429         case PERL_MAGIC_vstring:
 430         case PERL_MAGIC_utf8:
 431         case PERL_MAGIC_substr:
 432         case PERL_MAGIC_defelem:
 433         case PERL_MAGIC_arylen:
 434         case PERL_MAGIC_pos:
 435         case PERL_MAGIC_backref:
 436         case PERL_MAGIC_arylen_p:
 437         case PERL_MAGIC_rhash:
 438         case PERL_MAGIC_symtab:
 439             continue;
 440         }
 441
 442         if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
 443             (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
 444         else
 445             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 446                             mg->mg_ptr, mg->mg_len);
 447
 448         /* container types should remain read-only across localization */
 449         SvFLAGS(nsv) |= SvREADONLY(sv);
 450     }
 451
 452     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 453         SvFLAGS(nsv) |= SvMAGICAL(sv);
 454         PL_localizing = 1;
 455         SvSETMAGIC(nsv);
 456         PL_localizing = 0;
 457     }
 458 }
 459
 460 /*
 461 =for apidoc mg_free
 462
 463 Free any magic storage used by the SV.  See C<sv_magic>.
 464
 465 =cut
 466 */
 467
 468 int
 469 Perl_mg_free(pTHX_ SV *sv)
 470 {
 471     MAGIC* mg;
 472     MAGIC* moremagic;
 473     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 474         const MGVTBL* const vtbl = mg->mg_virtual;
 475         moremagic = mg->mg_moremagic;
 476         if (vtbl && vtbl->svt_free)
 477             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 478         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 479             if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 480                 Safefree(mg->mg_ptr);
 481             else if (mg->mg_len == HEf_SVKEY)
 482                 SvREFCNT_dec((SV*)mg->mg_ptr);
 483         }
 484         if (mg->mg_flags & MGf_REFCOUNTED)
 485             SvREFCNT_dec(mg->mg_obj);
 486         Safefree(mg);
 487     }
 488     SvMAGIC_set(sv, NULL);
 489     return 0;
 490 }
 491
 492 #include <signal.h>
 493
 494 U32
 495 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 496 {
 497     dVAR;
 498     PERL_UNUSED_ARG(sv);
 499
 500     if (PL_curpm) {
 501         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 502         if (rx) {
 503             if (mg->mg_obj) {                   /* @+ */
 504                 /* return the number possible */
 505                 return rx->nparens;
 506             } else {                            /* @- */
 507                 I32 paren = rx->lastparen;
 508
 509                 /* return the last filled */
 510                 while ( paren >= 0
 511                         && (rx->startp[paren] == -1 || rx->endp[paren] == -1) )
 512                     paren--;
 513                 return (U32)paren;
 514             }
 515         }
 516     }
 517
 518     return (U32)-1;
 519 }
 520
 521 int
 522 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 523 {
 524     dVAR;
 525     if (PL_curpm) {
 526         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 527         if (rx) {
 528             register const I32 paren = mg->mg_len;
 529             register I32 s;
 530             register I32 t;
 531             if (paren < 0)
 532                 return 0;
 533             if (paren <= (I32)rx->nparens &&
 534                 (s = rx->startp[paren]) != -1 &&
 535                 (t = rx->endp[paren]) != -1)
 536                 {
 537                     register I32 i;
 538                     if (mg->mg_obj)             /* @+ */
 539                         i = t;
 540                     else                        /* @- */
 541                         i = s;
 542
 543                     if (i > 0 && RX_MATCH_UTF8(rx)) {
 544                         const char * const b = rx->subbeg;
 545                         if (b)
 546                             i = utf8_length((U8*)b, (U8*)(b+i));
 547                     }
 548
 549                     sv_setiv(sv, i);
 550                 }
 551         }
 552     }
 553     return 0;
 554 }
 555
 556 int
 557 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 558 {
 559     PERL_UNUSED_ARG(sv);
 560     PERL_UNUSED_ARG(mg);
 561     Perl_croak(aTHX_ PL_no_modify);
 562     NORETURN_FUNCTION_END;
 563 }
 564
 565 U32
 566 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 567 {
 568     dVAR;
 569     register I32 paren;
 570     register I32 i;
 571     register const REGEXP *rx;
 572     I32 s1, t1;
 573
 574     switch (*mg->mg_ptr) {
 575     case '1': case '2': case '3': case '4':
 576     case '5': case '6': case '7': case '8': case '9': case '&':
 577         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 578
 579             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 580           getparen:
 581             if (paren <= (I32)rx->nparens &&
 582                 (s1 = rx->startp[paren]) != -1 &&
 583                 (t1 = rx->endp[paren]) != -1)
 584             {
 585                 i = t1 - s1;
 586               getlen:
 587                 if (i > 0 && RX_MATCH_UTF8(rx)) {
 588                     const char * const s = rx->subbeg + s1;
 589                     const U8 *ep;
 590                     STRLEN el;
 591
 592                     i = t1 - s1;
 593                     if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
 594                         i = el;
 595                 }
 596                 if (i < 0)
 597                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 598                 return i;
 599             }
 600             else {
 601                 if (ckWARN(WARN_UNINITIALIZED))
 602                     report_uninit(sv);
 603             }
 604         }
 605         else {
 606             if (ckWARN(WARN_UNINITIALIZED))
 607                 report_uninit(sv);
 608         }
 609         return 0;
 610     case '+':
 611         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 612             paren = rx->lastparen;
 613             if (paren)
 614                 goto getparen;
 615         }
 616         return 0;
 617     case '\016': /* ^N */
 618         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 619             paren = rx->lastcloseparen;
 620             if (paren)
 621                 goto getparen;
 622         }
 623         return 0;
 624     case '`':
 625         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 626             if (rx->startp[0] != -1) {
 627                 i = rx->startp[0];
 628                 if (i > 0) {
 629                     s1 = 0;
 630                     t1 = i;
 631                     goto getlen;
 632                 }
 633             }
 634         }
 635         return 0;
 636     case '\'':
 637         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 638             if (rx->endp[0] != -1) {
 639                 i = rx->sublen - rx->endp[0];
 640                 if (i > 0) {
 641                     s1 = rx->endp[0];
 642                     t1 = rx->sublen;
 643                     goto getlen;
 644                 }
 645             }
 646         }
 647         return 0;
 648     }
 649     magic_get(sv,mg);
 650     if (!SvPOK(sv) && SvNIOK(sv)) {
 651         sv_2pv(sv, 0);
 652     }
 653     if (SvPOK(sv))
 654         return SvCUR(sv);
 655     return 0;
 656 }
 657
 658 #define SvRTRIM(sv) STMT_START { \
 659     if (SvPOK(sv)) { \
 660         STRLEN len = SvCUR(sv); \
 661         char * const p = SvPVX(sv); \
 662         while (len > 0 && isSPACE(p[len-1])) \
 663            --len; \
 664         SvCUR_set(sv, len); \
 665         p[len] = '\0'; \
 666     } \
 667 } STMT_END
 668
 669 int
 670 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 671 {
 672     dVAR;
 673     register I32 paren;
 674     register char *s = NULL;
 675     register REGEXP *rx;
 676     const char * const remaining = mg->mg_ptr + 1;
 677     const char nextchar = *remaining;
 678
 679     switch (*mg->mg_ptr) {
 680     case '\001':                /* ^A */
 681         sv_setsv(sv, PL_bodytarget);
 682         break;
 683     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 684         if (nextchar == '\0') {
 685             sv_setiv(sv, (IV)PL_minus_c);
 686         }
 687         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 688             sv_setiv(sv, (IV)STATUS_NATIVE);
 689         }
 690         break;
 691
 692     case '\004':                /* ^D */
 693         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 694         break;
 695     case '\005':  /* ^E */
 696          if (nextchar == '\0') {
 697 #if defined(MACOS_TRADITIONAL)
 698              {
 699                   char msg[256];
 700
 701                   sv_setnv(sv,(double)gMacPerl_OSErr);
 702                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 703              }
 704 #elif defined(VMS)
 705              {
 706 #                 include <descrip.h>
 707 #                 include <starlet.h>
 708                   char msg[255];
 709                   $DESCRIPTOR(msgdsc,msg);
 710                   sv_setnv(sv,(NV) vaxc$errno);
 711                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 712                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 713                   else
 714                        sv_setpvn(sv,"",0);
 715              }
 716 #elif defined(OS2)
 717              if (!(_emx_env & 0x200)) { /* Under DOS */
 718                   sv_setnv(sv, (NV)errno);
 719                   sv_setpv(sv, errno ? Strerror(errno) : "");
 720              } else {
 721                   if (errno != errno_isOS2) {
 722                        const int tmp = _syserrno();
 723                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 724                             Perl_rc = tmp;
 725                   }
 726                   sv_setnv(sv, (NV)Perl_rc);
 727                   sv_setpv(sv, os2error(Perl_rc));
 728              }
 729 #elif defined(WIN32)
 730              {
 731                   const DWORD dwErr = GetLastError();
 732                   sv_setnv(sv, (NV)dwErr);
 733                   if (dwErr) {
 734                        PerlProc_GetOSError(sv, dwErr);
 735                   }
 736                   else
 737                        sv_setpvn(sv, "", 0);
 738                   SetLastError(dwErr);
 739              }
 740 #else
 741              {
 742                  const int saveerrno = errno;
 743                  sv_setnv(sv, (NV)errno);
 744                  sv_setpv(sv, errno ? Strerror(errno) : "");
 745                  errno = saveerrno;
 746              }
 747 #endif
 748              SvRTRIM(sv);
 749              SvNOK_on(sv);      /* what a wonderful hack! */
 750          }
 751          else if (strEQ(remaining, "NCODING"))
 752               sv_setsv(sv, PL_encoding);
 753          break;
 754     case '\006':                /* ^F */
 755         sv_setiv(sv, (IV)PL_maxsysfd);
 756         break;
 757     case '\010':                /* ^H */
 758         sv_setiv(sv, (IV)PL_hints);
 759         break;
 760     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 761         if (PL_inplace)
 762             sv_setpv(sv, PL_inplace);
 763         else
 764             sv_setsv(sv, &PL_sv_undef);
 765         break;
 766     case '\017':                /* ^O & ^OPEN */
 767         if (nextchar == '\0') {
 768             sv_setpv(sv, PL_osname);
 769             SvTAINTED_off(sv);
 770         }
 771         else if (strEQ(remaining, "PEN")) {
 772             if (!(CopHINTS_get(&PL_compiling) & HINT_LEXICAL_IO))
 773                 sv_setsv(sv, &PL_sv_undef);
 774             else {
 775                 sv_setsv(sv,
 776                          Perl_refcounted_he_fetch(aTHX_
 777                                                   PL_compiling.cop_hints_hash,
 778                                                   0, "open", 4, 0, 0));
 779             }
 780         }
 781         break;
 782     case '\020':
 783         if (nextchar == '\0') {       /* ^P */
 784             sv_setiv(sv, (IV)PL_perldb);
 785         } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
 786             goto do_prematch_fetch;
 787         } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
 788             goto do_postmatch_fetch;
 789         }
 790         break;
 791     case '\023':                /* ^S */
 792         if (nextchar == '\0') {
 793             if (PL_lex_state != LEX_NOTPARSING)
 794                 SvOK_off(sv);
 795             else if (PL_in_eval)
 796                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 797             else
 798                 sv_setiv(sv, 0);
 799         }
 800         break;
 801     case '\024':                /* ^T */
 802         if (nextchar == '\0') {
 803 #ifdef BIG_TIME
 804             sv_setnv(sv, PL_basetime);
 805 #else
 806             sv_setiv(sv, (IV)PL_basetime);
 807 #endif
 808         }
 809         else if (strEQ(remaining, "AINT"))
 810             sv_setiv(sv, PL_tainting
 811                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 812                     : 0);
 813         break;
 814     case '\025':                /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
 815         if (strEQ(remaining, "NICODE"))
 816             sv_setuv(sv, (UV) PL_unicode);
 817         else if (strEQ(remaining, "TF8LOCALE"))
 818             sv_setuv(sv, (UV) PL_utf8locale);
 819         else if (strEQ(remaining, "TF8CACHE"))
 820             sv_setiv(sv, (IV) PL_utf8cache);
 821         break;
 822     case '\027':                /* ^W  & $^WARNING_BITS */
 823         if (nextchar == '\0')
 824             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 825         else if (strEQ(remaining, "ARNING_BITS")) {
 826             if (PL_compiling.cop_warnings == pWARN_NONE) {
 827                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 828             }
 829             else if (PL_compiling.cop_warnings == pWARN_STD) {
 830                 sv_setpvn(
 831                     sv,
 832                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 833                     WARNsize
 834                 );
 835             }
 836             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 837                 /* Get the bit mask for $warnings::Bits{all}, because
 838                  * it could have been extended by warnings::register */
 839                 HV * const bits=get_hv("warnings::Bits", FALSE);
 840                 if (bits) {
 841                     SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
 842                     if (bits_all)
 843                         sv_setsv(sv, *bits_all);
 844                 }
 845                 else {
 846                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 847                 }
 848             }
 849             else {
 850                 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
 851                           *PL_compiling.cop_warnings);
 852             }
 853             SvPOK_only(sv);
 854         }
 855         break;
 856     case '\015': /* $^MATCH */
 857         if (strEQ(remaining, "ATCH")) {
 858     case '1': case '2': case '3': case '4':
 859     case '5': case '6': case '7': case '8': case '9': case '&':
 860             if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 861                 /*
 862                  * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 863                  * XXX Does the new way break anything?
 864                  */
 865                 paren = atoi(mg->mg_ptr); /* $& is in [0] */
 866                 reg_numbered_buff_get( paren, rx, sv, 0);
 867                 break;
 868             }
 869             sv_setsv(sv,&PL_sv_undef);
 870         }
 871         break;
 872     case '+':
 873         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 874             if (rx->lastparen) {
 875                 reg_numbered_buff_get( rx->lastparen, rx, sv, 0);
 876                 break;
 877             }
 878         }
 879         sv_setsv(sv,&PL_sv_undef);
 880         break;
 881     case '\016':                /* ^N */
 882         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 883             if (rx->lastcloseparen) {
 884                 reg_numbered_buff_get( rx->lastcloseparen, rx, sv, 0);
 885                 break;
 886             }
 887
 888         }
 889         sv_setsv(sv,&PL_sv_undef);
 890         break;
 891     case '`':
 892       do_prematch_fetch:
 893         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 894           reg_numbered_buff_get( -2, rx, sv, 0);
 895           break;
 896         }
 897         sv_setsv(sv,&PL_sv_undef);
 898         break;
 899     case '\'':
 900       do_postmatch_fetch:
 901         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 902           reg_numbered_buff_get( -1, rx, sv, 0);
 903           break;
 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         sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
 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         goto add_groups;
 996     case ')':
 997         sv_setiv(sv, (IV)PL_egid);
 998       add_groups:
 999 #ifdef HAS_GETGROUPS
1000         {
1001             Groups_t *gary = NULL;
1002             I32 i, num_groups = getgroups(0, gary);
1003             Newx(gary, num_groups, Groups_t);
1004             num_groups = getgroups(num_groups, gary);
1005             for (i = 0; i < num_groups; i++)
1006                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1007             Safefree(gary);
1008         }
1009         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1010 #endif
1011         break;
1012 #ifndef MACOS_TRADITIONAL
1013     case '0':
1014         break;
1015 #endif
1016     }
1017     return 0;
1018 }
1019
1020 int
1021 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1022 {
1023     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1024
1025     if (uf && uf->uf_val)
1026         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1027     return 0;
1028 }
1029
1030 int
1031 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1032 {
1033     dVAR;
1034     STRLEN len = 0, klen;
1035     const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1036     const char * const ptr = MgPV_const(mg,klen);
1037     my_setenv(ptr, s);
1038
1039 #ifdef DYNAMIC_ENV_FETCH
1040      /* We just undefd an environment var.  Is a replacement */
1041      /* waiting in the wings? */
1042     if (!len) {
1043         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1044         if (valp)
1045             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1046     }
1047 #endif
1048
1049 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1050                             /* And you'll never guess what the dog had */
1051                             /*   in its mouth... */
1052     if (PL_tainting) {
1053         MgTAINTEDDIR_off(mg);
1054 #ifdef VMS
1055         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1056             char pathbuf[256], eltbuf[256], *cp, *elt;
1057             Stat_t sbuf;
1058             int i = 0, j = 0;
1059
1060             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1061             elt = eltbuf;
1062             do {          /* DCL$PATH may be a search list */
1063                 while (1) {   /* as may dev portion of any element */
1064                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1065                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1066                              cando_by_name(S_IWUSR,0,elt) ) {
1067                             MgTAINTEDDIR_on(mg);
1068                             return 0;
1069                         }
1070                     }
1071                     if ((cp = strchr(elt, ':')) != NULL)
1072                         *cp = '\0';
1073                     if (my_trnlnm(elt, eltbuf, j++))
1074                         elt = eltbuf;
1075                     else
1076                         break;
1077                 }
1078                 j = 0;
1079             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1080         }
1081 #endif /* VMS */
1082         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1083             const char * const strend = s + len;
1084
1085             while (s < strend) {
1086                 char tmpbuf[256];
1087                 Stat_t st;
1088                 I32 i;
1089 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1090                 const char path_sep = '|';
1091 #else
1092                 const char path_sep = ':';
1093 #endif
1094                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1095                              s, strend, path_sep, &i);
1096                 s++;
1097                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1098 #ifdef VMS
1099                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1100 #else
1101                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1102 #endif
1103                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1104                     MgTAINTEDDIR_on(mg);
1105                     return 0;
1106                 }
1107             }
1108         }
1109     }
1110 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1111
1112     return 0;
1113 }
1114
1115 int
1116 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1117 {
1118     PERL_UNUSED_ARG(sv);
1119     my_setenv(MgPV_nolen_const(mg),NULL);
1120     return 0;
1121 }
1122
1123 int
1124 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1125 {
1126     dVAR;
1127     PERL_UNUSED_ARG(mg);
1128 #if defined(VMS)
1129     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1130 #else
1131     if (PL_localizing) {
1132         HE* entry;
1133         my_clearenv();
1134         hv_iterinit((HV*)sv);
1135         while ((entry = hv_iternext((HV*)sv))) {
1136             I32 keylen;
1137             my_setenv(hv_iterkey(entry, &keylen),
1138                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1139         }
1140     }
1141 #endif
1142     return 0;
1143 }
1144
1145 int
1146 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1147 {
1148     dVAR;
1149     PERL_UNUSED_ARG(sv);
1150     PERL_UNUSED_ARG(mg);
1151 #if defined(VMS)
1152     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1153 #else
1154     my_clearenv();
1155 #endif
1156     return 0;
1157 }
1158
1159 #ifndef PERL_MICRO
1160 #ifdef HAS_SIGPROCMASK
1161 static void
1162 restore_sigmask(pTHX_ SV *save_sv)
1163 {
1164     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1165     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1166 }
1167 #endif
1168 int
1169 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1170 {
1171     dVAR;
1172     /* Are we fetching a signal entry? */
1173     const I32 i = whichsig(MgPV_nolen_const(mg));
1174     if (i > 0) {
1175         if(PL_psig_ptr[i])
1176             sv_setsv(sv,PL_psig_ptr[i]);
1177         else {
1178             Sighandler_t sigstate = rsignal_state(i);
1179 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1180             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1181                 sigstate = SIG_IGN;
1182 #endif
1183 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1184             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1185                 sigstate = SIG_DFL;
1186 #endif
1187             /* cache state so we don't fetch it again */
1188             if(sigstate == (Sighandler_t) SIG_IGN)
1189                 sv_setpv(sv,"IGNORE");
1190             else
1191                 sv_setsv(sv,&PL_sv_undef);
1192             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1193             SvTEMP_off(sv);
1194         }
1195     }
1196     return 0;
1197 }
1198 int
1199 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1200 {
1201     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1202      * refactoring might be in order.
1203      */
1204     dVAR;
1205     register const char * const s = MgPV_nolen_const(mg);
1206     PERL_UNUSED_ARG(sv);
1207     if (*s == '_') {
1208         SV** svp = NULL;
1209         if (strEQ(s,"__DIE__"))
1210             svp = &PL_diehook;
1211         else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1212             svp = &PL_warnhook;
1213         if (svp && *svp) {
1214             SV *const to_dec = *svp;
1215             *svp = NULL;
1216             SvREFCNT_dec(to_dec);
1217         }
1218     }
1219     else {
1220         /* Are we clearing a signal entry? */
1221         const I32 i = whichsig(s);
1222         if (i > 0) {
1223 #ifdef HAS_SIGPROCMASK
1224             sigset_t set, save;
1225             SV* save_sv;
1226             /* Avoid having the signal arrive at a bad time, if possible. */
1227             sigemptyset(&set);
1228             sigaddset(&set,i);
1229             sigprocmask(SIG_BLOCK, &set, &save);
1230             ENTER;
1231             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1232             SAVEFREESV(save_sv);
1233             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1234 #endif
1235             PERL_ASYNC_CHECK();
1236 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1237             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1238 #endif
1239 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1240             PL_sig_defaulting[i] = 1;
1241             (void)rsignal(i, PL_csighandlerp);
1242 #else
1243             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1244 #endif
1245             if(PL_psig_name[i]) {
1246                 SvREFCNT_dec(PL_psig_name[i]);
1247                 PL_psig_name[i]=0;
1248             }
1249             if(PL_psig_ptr[i]) {
1250                 SV * const to_dec=PL_psig_ptr[i];
1251                 PL_psig_ptr[i]=0;
1252                 LEAVE;
1253                 SvREFCNT_dec(to_dec);
1254             }
1255             else
1256                 LEAVE;
1257         }
1258     }
1259     return 0;
1260 }
1261
1262 #ifndef SIG_PENDING_DIE_COUNT
1263 #  define SIG_PENDING_DIE_COUNT 120
1264 #endif
1265
1266 static void
1267 S_raise_signal(pTHX_ int sig)
1268 {
1269     dVAR;
1270     /* Set a flag to say this signal is pending */
1271     PL_psig_pend[sig]++;
1272     /* And one to say _a_ signal is pending */
1273     if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1274         Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1275                 (unsigned long)SIG_PENDING_DIE_COUNT);
1276 }
1277
1278 Signal_t
1279 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1280 Perl_csighandler(int sig, ...)
1281 #else
1282 Perl_csighandler(int sig)
1283 #endif
1284 {
1285 #ifdef PERL_GET_SIG_CONTEXT
1286     dTHXa(PERL_GET_SIG_CONTEXT);
1287 #else
1288     dTHX;
1289 #endif
1290 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1291     (void) rsignal(sig, PL_csighandlerp);
1292     if (PL_sig_ignoring[sig]) return;
1293 #endif
1294 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1295     if (PL_sig_defaulting[sig])
1296 #ifdef KILL_BY_SIGPRC
1297             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1298 #else
1299             exit(1);
1300 #endif
1301 #endif
1302    if (
1303 #ifdef SIGILL
1304            sig == SIGILL ||
1305 #endif
1306 #ifdef SIGBUS
1307            sig == SIGBUS ||
1308 #endif
1309 #ifdef SIGSEGV
1310            sig == SIGSEGV ||
1311 #endif
1312            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1313         /* Call the perl level handler now--
1314          * with risk we may be in malloc() etc. */
1315         (*PL_sighandlerp)(sig);
1316    else
1317         S_raise_signal(aTHX_ sig);
1318 }
1319
1320 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1321 void
1322 Perl_csighandler_init(void)
1323 {
1324     int sig;
1325     if (PL_sig_handlers_initted) return;
1326
1327     for (sig = 1; sig < SIG_SIZE; sig++) {
1328 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1329         dTHX;
1330         PL_sig_defaulting[sig] = 1;
1331         (void) rsignal(sig, PL_csighandlerp);
1332 #endif
1333 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1334         PL_sig_ignoring[sig] = 0;
1335 #endif
1336     }
1337     PL_sig_handlers_initted = 1;
1338 }
1339 #endif
1340
1341 void
1342 Perl_despatch_signals(pTHX)
1343 {
1344     dVAR;
1345     int sig;
1346     PL_sig_pending = 0;
1347     for (sig = 1; sig < SIG_SIZE; sig++) {
1348         if (PL_psig_pend[sig]) {
1349             PERL_BLOCKSIG_ADD(set, sig);
1350             PL_psig_pend[sig] = 0;
1351             PERL_BLOCKSIG_BLOCK(set);
1352             (*PL_sighandlerp)(sig);
1353             PERL_BLOCKSIG_UNBLOCK(set);
1354         }
1355     }
1356 }
1357
1358 int
1359 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1360 {
1361     dVAR;
1362     I32 i;
1363     SV** svp = NULL;
1364     /* Need to be careful with SvREFCNT_dec(), because that can have side
1365      * effects (due to closures). We must make sure that the new disposition
1366      * is in place before it is called.
1367      */
1368     SV* to_dec = NULL;
1369     STRLEN len;
1370 #ifdef HAS_SIGPROCMASK
1371     sigset_t set, save;
1372     SV* save_sv;
1373 #endif
1374
1375     register const char *s = MgPV_const(mg,len);
1376     if (*s == '_') {
1377         if (strEQ(s,"__DIE__"))
1378             svp = &PL_diehook;
1379         else if (strEQ(s,"__WARN__"))
1380             svp = &PL_warnhook;
1381         else
1382             Perl_croak(aTHX_ "No such hook: %s", s);
1383         i = 0;
1384         if (*svp) {
1385             if (*svp != PERL_WARNHOOK_FATAL)
1386                 to_dec = *svp;
1387             *svp = NULL;
1388         }
1389     }
1390     else {
1391         i = whichsig(s);        /* ...no, a brick */
1392         if (i <= 0) {
1393             if (ckWARN(WARN_SIGNAL))
1394                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1395             return 0;
1396         }
1397 #ifdef HAS_SIGPROCMASK
1398         /* Avoid having the signal arrive at a bad time, if possible. */
1399         sigemptyset(&set);
1400         sigaddset(&set,i);
1401         sigprocmask(SIG_BLOCK, &set, &save);
1402         ENTER;
1403         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1404         SAVEFREESV(save_sv);
1405         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1406 #endif
1407         PERL_ASYNC_CHECK();
1408 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1409         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1410 #endif
1411 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1412         PL_sig_ignoring[i] = 0;
1413 #endif
1414 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1415         PL_sig_defaulting[i] = 0;
1416 #endif
1417         SvREFCNT_dec(PL_psig_name[i]);
1418         to_dec = PL_psig_ptr[i];
1419         PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1420         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1421         PL_psig_name[i] = newSVpvn(s, len);
1422         SvREADONLY_on(PL_psig_name[i]);
1423     }
1424     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1425         if (i) {
1426             (void)rsignal(i, PL_csighandlerp);
1427 #ifdef HAS_SIGPROCMASK
1428             LEAVE;
1429 #endif
1430         }
1431         else
1432             *svp = SvREFCNT_inc_simple_NN(sv);
1433         if(to_dec)
1434             SvREFCNT_dec(to_dec);
1435         return 0;
1436     }
1437     s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1438     if (strEQ(s,"IGNORE")) {
1439         if (i) {
1440 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1441             PL_sig_ignoring[i] = 1;
1442             (void)rsignal(i, PL_csighandlerp);
1443 #else
1444             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1445 #endif
1446         }
1447     }
1448     else if (strEQ(s,"DEFAULT") || !*s) {
1449         if (i)
1450 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1451           {
1452             PL_sig_defaulting[i] = 1;
1453             (void)rsignal(i, PL_csighandlerp);
1454           }
1455 #else
1456             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1457 #endif
1458     }
1459     else {
1460         /*
1461          * We should warn if HINT_STRICT_REFS, but without
1462          * access to a known hint bit in a known OP, we can't
1463          * tell whether HINT_STRICT_REFS is in force or not.
1464          */
1465         if (!strchr(s,':') && !strchr(s,'\''))
1466             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1467         if (i)
1468             (void)rsignal(i, PL_csighandlerp);
1469         else
1470             *svp = SvREFCNT_inc_simple_NN(sv);
1471     }
1472 #ifdef HAS_SIGPROCMASK
1473     if(i)
1474         LEAVE;
1475 #endif
1476     if(to_dec)
1477         SvREFCNT_dec(to_dec);
1478     return 0;
1479 }
1480 #endif /* !PERL_MICRO */
1481
1482 int
1483 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1484 {
1485     dVAR;
1486     PERL_UNUSED_ARG(sv);
1487     PERL_UNUSED_ARG(mg);
1488     PL_sub_generation++;
1489     return 0;
1490 }
1491
1492 int
1493 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1494 {
1495     dVAR;
1496     PERL_UNUSED_ARG(sv);
1497     PERL_UNUSED_ARG(mg);
1498     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1499     PL_amagic_generation++;
1500
1501     return 0;
1502 }
1503
1504 int
1505 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1506 {
1507     HV * const hv = (HV*)LvTARG(sv);
1508     I32 i = 0;
1509     PERL_UNUSED_ARG(mg);
1510
1511     if (hv) {
1512          (void) hv_iterinit(hv);
1513          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1514              i = HvKEYS(hv);
1515          else {
1516              while (hv_iternext(hv))
1517                  i++;
1518          }
1519     }
1520
1521     sv_setiv(sv, (IV)i);
1522     return 0;
1523 }
1524
1525 int
1526 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1527 {
1528     PERL_UNUSED_ARG(mg);
1529     if (LvTARG(sv)) {
1530         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1531     }
1532     return 0;
1533 }
1534
1535 /* caller is responsible for stack switching/cleanup */
1536 STATIC int
1537 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1538 {
1539     dVAR;
1540     dSP;
1541
1542     PUSHMARK(SP);
1543     EXTEND(SP, n);
1544     PUSHs(SvTIED_obj(sv, mg));
1545     if (n > 1) {
1546         if (mg->mg_ptr) {
1547             if (mg->mg_len >= 0)
1548                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1549             else if (mg->mg_len == HEf_SVKEY)
1550                 PUSHs((SV*)mg->mg_ptr);
1551         }
1552         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1553             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1554         }
1555     }
1556     if (n > 2) {
1557         PUSHs(val);
1558     }
1559     PUTBACK;
1560
1561     return call_method(meth, flags);
1562 }
1563
1564 STATIC int
1565 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1566 {
1567     dVAR; dSP;
1568
1569     ENTER;
1570     SAVETMPS;
1571     PUSHSTACKi(PERLSI_MAGIC);
1572
1573     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1574         sv_setsv(sv, *PL_stack_sp--);
1575     }
1576
1577     POPSTACK;
1578     FREETMPS;
1579     LEAVE;
1580     return 0;
1581 }
1582
1583 int
1584 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1585 {
1586     if (mg->mg_ptr)
1587         mg->mg_flags |= MGf_GSKIP;
1588     magic_methpack(sv,mg,"FETCH");
1589     return 0;
1590 }
1591
1592 int
1593 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1594 {
1595     dVAR; dSP;
1596     ENTER;
1597     PUSHSTACKi(PERLSI_MAGIC);
1598     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1599     POPSTACK;
1600     LEAVE;
1601     return 0;
1602 }
1603
1604 int
1605 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1606 {
1607     return magic_methpack(sv,mg,"DELETE");
1608 }
1609
1610
1611 U32
1612 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1613 {
1614     dVAR; dSP;
1615     U32 retval = 0;
1616
1617     ENTER;
1618     SAVETMPS;
1619     PUSHSTACKi(PERLSI_MAGIC);
1620     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1621         sv = *PL_stack_sp--;
1622         retval = (U32) SvIV(sv)-1;
1623     }
1624     POPSTACK;
1625     FREETMPS;
1626     LEAVE;
1627     return retval;
1628 }
1629
1630 int
1631 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1632 {
1633     dVAR; dSP;
1634
1635     ENTER;
1636     PUSHSTACKi(PERLSI_MAGIC);
1637     PUSHMARK(SP);
1638     XPUSHs(SvTIED_obj(sv, mg));
1639     PUTBACK;
1640     call_method("CLEAR", G_SCALAR|G_DISCARD);
1641     POPSTACK;
1642     LEAVE;
1643
1644     return 0;
1645 }
1646
1647 int
1648 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1649 {
1650     dVAR; dSP;
1651     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1652
1653     ENTER;
1654     SAVETMPS;
1655     PUSHSTACKi(PERLSI_MAGIC);
1656     PUSHMARK(SP);
1657     EXTEND(SP, 2);
1658     PUSHs(SvTIED_obj(sv, mg));
1659     if (SvOK(key))
1660         PUSHs(key);
1661     PUTBACK;
1662
1663     if (call_method(meth, G_SCALAR))
1664         sv_setsv(key, *PL_stack_sp--);
1665
1666     POPSTACK;
1667     FREETMPS;
1668     LEAVE;
1669     return 0;
1670 }
1671
1672 int
1673 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1674 {
1675     return magic_methpack(sv,mg,"EXISTS");
1676 }
1677
1678 SV *
1679 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1680 {
1681     dVAR; dSP;
1682     SV *retval;
1683     SV * const tied = SvTIED_obj((SV*)hv, mg);
1684     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1685
1686     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1687         SV *key;
1688         if (HvEITER_get(hv))
1689             /* we are in an iteration so the hash cannot be empty */
1690             return &PL_sv_yes;
1691         /* no xhv_eiter so now use FIRSTKEY */
1692         key = sv_newmortal();
1693         magic_nextpack((SV*)hv, mg, key);
1694         HvEITER_set(hv, NULL);     /* need to reset iterator */
1695         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1696     }
1697
1698     /* there is a SCALAR method that we can call */
1699     ENTER;
1700     PUSHSTACKi(PERLSI_MAGIC);
1701     PUSHMARK(SP);
1702     EXTEND(SP, 1);
1703     PUSHs(tied);
1704     PUTBACK;
1705
1706     if (call_method("SCALAR", G_SCALAR))
1707         retval = *PL_stack_sp--;
1708     else
1709         retval = &PL_sv_undef;
1710     POPSTACK;
1711     LEAVE;
1712     return retval;
1713 }
1714
1715 int
1716 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1717 {
1718     dVAR;
1719     GV * const gv = PL_DBline;
1720     const I32 i = SvTRUE(sv);
1721     SV ** const svp = av_fetch(GvAV(gv),
1722                      atoi(MgPV_nolen_const(mg)), FALSE);
1723     if (svp && SvIOKp(*svp)) {
1724         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1725         if (o) {
1726             /* set or clear breakpoint in the relevant control op */
1727             if (i)
1728                 o->op_flags |= OPf_SPECIAL;
1729             else
1730                 o->op_flags &= ~OPf_SPECIAL;
1731         }
1732     }
1733     return 0;
1734 }
1735
1736 int
1737 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1738 {
1739     dVAR;
1740     const AV * const obj = (AV*)mg->mg_obj;
1741     if (obj) {
1742         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1743     } else {
1744         SvOK_off(sv);
1745     }
1746     return 0;
1747 }
1748
1749 int
1750 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1751 {
1752     dVAR;
1753     AV * const obj = (AV*)mg->mg_obj;
1754     if (obj) {
1755         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1756     } else {
1757         if (ckWARN(WARN_MISC))
1758             Perl_warner(aTHX_ packWARN(WARN_MISC),
1759                         "Attempt to set length of freed array");
1760     }
1761     return 0;
1762 }
1763
1764 int
1765 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1766 {
1767     dVAR;
1768     PERL_UNUSED_ARG(sv);
1769     /* during global destruction, mg_obj may already have been freed */
1770     if (PL_in_clean_all)
1771         return 0;
1772
1773     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1774
1775     if (mg) {
1776         /* arylen scalar holds a pointer back to the array, but doesn't own a
1777            reference. Hence the we (the array) are about to go away with it
1778            still pointing at us. Clear its pointer, else it would be pointing
1779            at free memory. See the comment in sv_magic about reference loops,
1780            and why it can't own a reference to us.  */
1781         mg->mg_obj = 0;
1782     }
1783     return 0;
1784 }
1785
1786 int
1787 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1788 {
1789     dVAR;
1790     SV* const lsv = LvTARG(sv);
1791     PERL_UNUSED_ARG(mg);
1792
1793     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1794         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1795         if (found && found->mg_len >= 0) {
1796             I32 i = found->mg_len;
1797             if (DO_UTF8(lsv))
1798                 sv_pos_b2u(lsv, &i);
1799             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1800             return 0;
1801         }
1802     }
1803     SvOK_off(sv);
1804     return 0;
1805 }
1806
1807 int
1808 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1809 {
1810     dVAR;
1811     SV* const lsv = LvTARG(sv);
1812     SSize_t pos;
1813     STRLEN len;
1814     STRLEN ulen = 0;
1815     MAGIC* found;
1816
1817     PERL_UNUSED_ARG(mg);
1818
1819     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1820         found = mg_find(lsv, PERL_MAGIC_regex_global);
1821     else
1822         found = NULL;
1823     if (!found) {
1824         if (!SvOK(sv))
1825             return 0;
1826 #ifdef PERL_OLD_COPY_ON_WRITE
1827     if (SvIsCOW(lsv))
1828         sv_force_normal_flags(lsv, 0);
1829 #endif
1830         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1831                             NULL, 0);
1832     }
1833     else if (!SvOK(sv)) {
1834         found->mg_len = -1;
1835         return 0;
1836     }
1837     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1838
1839     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1840
1841     if (DO_UTF8(lsv)) {
1842         ulen = sv_len_utf8(lsv);
1843         if (ulen)
1844             len = ulen;
1845     }
1846
1847     if (pos < 0) {
1848         pos += len;
1849         if (pos < 0)
1850             pos = 0;
1851     }
1852     else if (pos > (SSize_t)len)
1853         pos = len;
1854
1855     if (ulen) {
1856         I32 p = pos;
1857         sv_pos_u2b(lsv, &p, 0);
1858         pos = p;
1859     }
1860
1861     found->mg_len = pos;
1862     found->mg_flags &= ~MGf_MINMATCH;
1863
1864     return 0;
1865 }
1866
1867 int
1868 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1869 {
1870     GV* gv;
1871     PERL_UNUSED_ARG(mg);
1872
1873     if (!SvOK(sv))
1874         return 0;
1875     if (isGV_with_GP(sv)) {
1876         /* We're actually already a typeglob, so don't need the stuff below.
1877          */
1878         return 0;
1879     }
1880     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1881     if (sv == (SV*)gv)
1882         return 0;
1883     if (GvGP(sv))
1884         gp_free((GV*)sv);
1885     GvGP(sv) = gp_ref(GvGP(gv));
1886     return 0;
1887 }
1888
1889 int
1890 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1891 {
1892     STRLEN len;
1893     SV * const lsv = LvTARG(sv);
1894     const char * const tmps = SvPV_const(lsv,len);
1895     I32 offs = LvTARGOFF(sv);
1896     I32 rem = LvTARGLEN(sv);
1897     PERL_UNUSED_ARG(mg);
1898
1899     if (SvUTF8(lsv))
1900         sv_pos_u2b(lsv, &offs, &rem);
1901     if (offs > (I32)len)
1902         offs = len;
1903     if (rem + offs > (I32)len)
1904         rem = len - offs;
1905     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1906     if (SvUTF8(lsv))
1907         SvUTF8_on(sv);
1908     return 0;
1909 }
1910
1911 int
1912 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1913 {
1914     dVAR;
1915     STRLEN len;
1916     const char * const tmps = SvPV_const(sv, len);
1917     SV * const lsv = LvTARG(sv);
1918     I32 lvoff = LvTARGOFF(sv);
1919     I32 lvlen = LvTARGLEN(sv);
1920     PERL_UNUSED_ARG(mg);
1921
1922     if (DO_UTF8(sv)) {
1923         sv_utf8_upgrade(lsv);
1924         sv_pos_u2b(lsv, &lvoff, &lvlen);
1925         sv_insert(lsv, lvoff, lvlen, tmps, len);
1926         LvTARGLEN(sv) = sv_len_utf8(sv);
1927         SvUTF8_on(lsv);
1928     }
1929     else if (lsv && SvUTF8(lsv)) {
1930         const char *utf8;
1931         sv_pos_u2b(lsv, &lvoff, &lvlen);
1932         LvTARGLEN(sv) = len;
1933         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1934         sv_insert(lsv, lvoff, lvlen, utf8, len);
1935         Safefree(utf8);
1936     }
1937     else {
1938         sv_insert(lsv, lvoff, lvlen, tmps, len);
1939         LvTARGLEN(sv) = len;
1940     }
1941
1942
1943     return 0;
1944 }
1945
1946 int
1947 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1948 {
1949     dVAR;
1950     PERL_UNUSED_ARG(sv);
1951     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1952     return 0;
1953 }
1954
1955 int
1956 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1957 {
1958     dVAR;
1959     PERL_UNUSED_ARG(sv);
1960     /* update taint status unless we're restoring at scope exit */
1961     if (PL_localizing != 2) {
1962         if (PL_tainted)
1963             mg->mg_len |= 1;
1964         else
1965             mg->mg_len &= ~1;
1966     }
1967     return 0;
1968 }
1969
1970 int
1971 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1972 {
1973     SV * const lsv = LvTARG(sv);
1974     PERL_UNUSED_ARG(mg);
1975
1976     if (lsv)
1977         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1978     else
1979         SvOK_off(sv);
1980
1981     return 0;
1982 }
1983
1984 int
1985 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1986 {
1987     PERL_UNUSED_ARG(mg);
1988     do_vecset(sv);      /* XXX slurp this routine */
1989     return 0;
1990 }
1991
1992 int
1993 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1994 {
1995     dVAR;
1996     SV *targ = NULL;
1997     if (LvTARGLEN(sv)) {
1998         if (mg->mg_obj) {
1999             SV * const ahv = LvTARG(sv);
2000             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2001             if (he)
2002                 targ = HeVAL(he);
2003         }
2004         else {
2005             AV* const av = (AV*)LvTARG(sv);
2006             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2007                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2008         }
2009         if (targ && (targ != &PL_sv_undef)) {
2010             /* somebody else defined it for us */
2011             SvREFCNT_dec(LvTARG(sv));
2012             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2013             LvTARGLEN(sv) = 0;
2014             SvREFCNT_dec(mg->mg_obj);
2015             mg->mg_obj = NULL;
2016             mg->mg_flags &= ~MGf_REFCOUNTED;
2017         }
2018     }
2019     else
2020         targ = LvTARG(sv);
2021     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2022     return 0;
2023 }
2024
2025 int
2026 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2027 {
2028     PERL_UNUSED_ARG(mg);
2029     if (LvTARGLEN(sv))
2030         vivify_defelem(sv);
2031     if (LvTARG(sv)) {
2032         sv_setsv(LvTARG(sv), sv);
2033         SvSETMAGIC(LvTARG(sv));
2034     }
2035     return 0;
2036 }
2037
2038 void
2039 Perl_vivify_defelem(pTHX_ SV *sv)
2040 {
2041     dVAR;
2042     MAGIC *mg;
2043     SV *value = NULL;
2044
2045     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2046         return;
2047     if (mg->mg_obj) {
2048         SV * const ahv = LvTARG(sv);
2049         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2050         if (he)
2051             value = HeVAL(he);
2052         if (!value || value == &PL_sv_undef)
2053             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2054     }
2055     else {
2056         AV* const av = (AV*)LvTARG(sv);
2057         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2058             LvTARG(sv) = NULL;  /* array can't be extended */
2059         else {
2060             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2061             if (!svp || (value = *svp) == &PL_sv_undef)
2062                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2063         }
2064     }
2065     SvREFCNT_inc_simple_void(value);
2066     SvREFCNT_dec(LvTARG(sv));
2067     LvTARG(sv) = value;
2068     LvTARGLEN(sv) = 0;
2069     SvREFCNT_dec(mg->mg_obj);
2070     mg->mg_obj = NULL;
2071     mg->mg_flags &= ~MGf_REFCOUNTED;
2072 }
2073
2074 int
2075 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2076 {
2077     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2078 }
2079
2080 int
2081 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2082 {
2083     PERL_UNUSED_CONTEXT;
2084     mg->mg_len = -1;
2085     SvSCREAM_off(sv);
2086     return 0;
2087 }
2088
2089 int
2090 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2091 {
2092     PERL_UNUSED_ARG(mg);
2093     sv_unmagic(sv, PERL_MAGIC_bm);
2094     SvTAIL_off(sv);
2095     SvVALID_off(sv);
2096     return 0;
2097 }
2098
2099 int
2100 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2101 {
2102     PERL_UNUSED_ARG(mg);
2103     sv_unmagic(sv, PERL_MAGIC_fm);
2104     SvCOMPILED_off(sv);
2105     return 0;
2106 }
2107
2108 int
2109 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2110 {
2111     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2112
2113     if (uf && uf->uf_set)
2114         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2115     return 0;
2116 }
2117
2118 int
2119 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2120 {
2121     PERL_UNUSED_ARG(mg);
2122     sv_unmagic(sv, PERL_MAGIC_qr);
2123     return 0;
2124 }
2125
2126 int
2127 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2128 {
2129     dVAR;
2130     regexp * const re = (regexp *)mg->mg_obj;
2131     PERL_UNUSED_ARG(sv);
2132
2133     ReREFCNT_dec(re);
2134     return 0;
2135 }
2136
2137 #ifdef USE_LOCALE_COLLATE
2138 int
2139 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2140 {
2141     /*
2142      * RenE<eacute> Descartes said "I think not."
2143      * and vanished with a faint plop.
2144      */
2145     PERL_UNUSED_CONTEXT;
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_CONTEXT;
2161     PERL_UNUSED_ARG(sv);
2162     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2163     mg->mg_ptr = NULL;
2164     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2165     return 0;
2166 }
2167
2168 int
2169 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2170 {
2171     dVAR;
2172     register const char *s;
2173     I32 i;
2174     STRLEN len;
2175     switch (*mg->mg_ptr) {
2176     case '\001':        /* ^A */
2177         sv_setsv(PL_bodytarget, sv);
2178         break;
2179     case '\003':        /* ^C */
2180         PL_minus_c = (bool)SvIV(sv);
2181         break;
2182
2183     case '\004':        /* ^D */
2184 #ifdef DEBUGGING
2185         s = SvPV_nolen_const(sv);
2186         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2187         DEBUG_x(dump_all());
2188 #else
2189         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2190 #endif
2191         break;
2192     case '\005':  /* ^E */
2193         if (*(mg->mg_ptr+1) == '\0') {
2194 #ifdef MACOS_TRADITIONAL
2195             gMacPerl_OSErr = SvIV(sv);
2196 #else
2197 #  ifdef VMS
2198             set_vaxc_errno(SvIV(sv));
2199 #  else
2200 #    ifdef WIN32
2201             SetLastError( SvIV(sv) );
2202 #    else
2203 #      ifdef OS2
2204             os2_setsyserrno(SvIV(sv));
2205 #      else
2206             /* will anyone ever use this? */
2207             SETERRNO(SvIV(sv), 4);
2208 #      endif
2209 #    endif
2210 #  endif
2211 #endif
2212         }
2213         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2214             if (PL_encoding)
2215                 SvREFCNT_dec(PL_encoding);
2216             if (SvOK(sv) || SvGMAGICAL(sv)) {
2217                 PL_encoding = newSVsv(sv);
2218             }
2219             else {
2220                 PL_encoding = NULL;
2221             }
2222         }
2223         break;
2224     case '\006':        /* ^F */
2225         PL_maxsysfd = SvIV(sv);
2226         break;
2227     case '\010':        /* ^H */
2228         PL_hints = SvIV(sv);
2229         break;
2230     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2231         Safefree(PL_inplace);
2232         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2233         break;
2234     case '\017':        /* ^O */
2235         if (*(mg->mg_ptr+1) == '\0') {
2236             Safefree(PL_osname);
2237             PL_osname = NULL;
2238             if (SvOK(sv)) {
2239                 TAINT_PROPER("assigning to $^O");
2240                 PL_osname = savesvpv(sv);
2241             }
2242         }
2243         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2244             PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2245             PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2246             PL_compiling.cop_hints_hash
2247                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2248                                          sv_2mortal(newSVpvs("open")), sv);
2249         }
2250         break;
2251     case '\020':        /* ^P */
2252         PL_perldb = SvIV(sv);
2253         if (PL_perldb && !PL_DBsingle)
2254             init_debugger();
2255         break;
2256     case '\024':        /* ^T */
2257 #ifdef BIG_TIME
2258         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2259 #else
2260         PL_basetime = (Time_t)SvIV(sv);
2261 #endif
2262         break;
2263     case '\025':        /* ^UTF8CACHE */
2264          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2265              PL_utf8cache = (signed char) sv_2iv(sv);
2266          }
2267          break;
2268     case '\027':        /* ^W & $^WARNING_BITS */
2269         if (*(mg->mg_ptr+1) == '\0') {
2270             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2271                 i = SvIV(sv);
2272                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2273                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2274             }
2275         }
2276         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2277             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2278                 if (!SvPOK(sv) && PL_localizing) {
2279                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2280                     PL_compiling.cop_warnings = pWARN_NONE;
2281                     break;
2282                 }
2283                 {
2284                     STRLEN len, i;
2285                     int accumulate = 0 ;
2286                     int any_fatals = 0 ;
2287                     const char * const ptr = SvPV_const(sv, len) ;
2288                     for (i = 0 ; i < len ; ++i) {
2289                         accumulate |= ptr[i] ;
2290                         any_fatals |= (ptr[i] & 0xAA) ;
2291                     }
2292                     if (!accumulate) {
2293                         if (!specialWARN(PL_compiling.cop_warnings))
2294                             PerlMemShared_free(PL_compiling.cop_warnings);
2295                         PL_compiling.cop_warnings = pWARN_NONE;
2296                     }
2297                     /* Yuck. I can't see how to abstract this:  */
2298                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2299                                        WARN_ALL) && !any_fatals) {
2300                         if (!specialWARN(PL_compiling.cop_warnings))
2301                             PerlMemShared_free(PL_compiling.cop_warnings);
2302                         PL_compiling.cop_warnings = pWARN_ALL;
2303                         PL_dowarn |= G_WARN_ONCE ;
2304                     }
2305                     else {
2306                         STRLEN len;
2307                         const char *const p = SvPV_const(sv, len);
2308
2309                         PL_compiling.cop_warnings
2310                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2311                                                          p, len);
2312
2313                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2314                             PL_dowarn |= G_WARN_ONCE ;
2315                     }
2316
2317                 }
2318             }
2319         }
2320         break;
2321     case '.':
2322         if (PL_localizing) {
2323             if (PL_localizing == 1)
2324                 SAVESPTR(PL_last_in_gv);
2325         }
2326         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2327             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2328         break;
2329     case '^':
2330         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2331         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2332         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2333         break;
2334     case '~':
2335         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2336         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2337         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2338         break;
2339     case '=':
2340         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2341         break;
2342     case '-':
2343         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2344         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2345             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2346         break;
2347     case '%':
2348         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2349         break;
2350     case '|':
2351         {
2352             IO * const io = GvIOp(PL_defoutgv);
2353             if(!io)
2354               break;
2355             if ((SvIV(sv)) == 0)
2356                 IoFLAGS(io) &= ~IOf_FLUSH;
2357             else {
2358                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2359                     PerlIO *ofp = IoOFP(io);
2360                     if (ofp)
2361                         (void)PerlIO_flush(ofp);
2362                     IoFLAGS(io) |= IOf_FLUSH;
2363                 }
2364             }
2365         }
2366         break;
2367     case '/':
2368         SvREFCNT_dec(PL_rs);
2369         PL_rs = newSVsv(sv);
2370         break;
2371     case '\\':
2372         if (PL_ors_sv)
2373             SvREFCNT_dec(PL_ors_sv);
2374         if (SvOK(sv) || SvGMAGICAL(sv)) {
2375             PL_ors_sv = newSVsv(sv);
2376         }
2377         else {
2378             PL_ors_sv = NULL;
2379         }
2380         break;
2381     case ',':
2382         if (PL_ofs_sv)
2383             SvREFCNT_dec(PL_ofs_sv);
2384         if (SvOK(sv) || SvGMAGICAL(sv)) {
2385             PL_ofs_sv = newSVsv(sv);
2386         }
2387         else {
2388             PL_ofs_sv = NULL;
2389         }
2390         break;
2391     case '[':
2392         CopARYBASE_set(&PL_compiling, SvIV(sv));
2393         break;
2394     case '?':
2395 #ifdef COMPLEX_STATUS
2396         if (PL_localizing == 2) {
2397             PL_statusvalue = LvTARGOFF(sv);
2398             PL_statusvalue_vms = LvTARGLEN(sv);
2399         }
2400         else
2401 #endif
2402 #ifdef VMSISH_STATUS
2403         if (VMSISH_STATUS)
2404             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2405         else
2406 #endif
2407             STATUS_UNIX_EXIT_SET(SvIV(sv));
2408         break;
2409     case '!':
2410         {
2411 #ifdef VMS
2412 #   define PERL_VMS_BANG vaxc$errno
2413 #else
2414 #   define PERL_VMS_BANG 0
2415 #endif
2416         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2417                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2418         }
2419         break;
2420     case '<':
2421         PL_uid = SvIV(sv);
2422         if (PL_delaymagic) {
2423             PL_delaymagic |= DM_RUID;
2424             break;                              /* don't do magic till later */
2425         }
2426 #ifdef HAS_SETRUID
2427         (void)setruid((Uid_t)PL_uid);
2428 #else
2429 #ifdef HAS_SETREUID
2430         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2431 #else
2432 #ifdef HAS_SETRESUID
2433       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2434 #else
2435         if (PL_uid == PL_euid) {                /* special case $< = $> */
2436 #ifdef PERL_DARWIN
2437             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2438             if (PL_uid != 0 && PerlProc_getuid() == 0)
2439                 (void)PerlProc_setuid(0);
2440 #endif
2441             (void)PerlProc_setuid(PL_uid);
2442         } else {
2443             PL_uid = PerlProc_getuid();
2444             Perl_croak(aTHX_ "setruid() not implemented");
2445         }
2446 #endif
2447 #endif
2448 #endif
2449         PL_uid = PerlProc_getuid();
2450         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2451         break;
2452     case '>':
2453         PL_euid = SvIV(sv);
2454         if (PL_delaymagic) {
2455             PL_delaymagic |= DM_EUID;
2456             break;                              /* don't do magic till later */
2457         }
2458 #ifdef HAS_SETEUID
2459         (void)seteuid((Uid_t)PL_euid);
2460 #else
2461 #ifdef HAS_SETREUID
2462         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2463 #else
2464 #ifdef HAS_SETRESUID
2465         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2466 #else
2467         if (PL_euid == PL_uid)          /* special case $> = $< */
2468             PerlProc_setuid(PL_euid);
2469         else {
2470             PL_euid = PerlProc_geteuid();
2471             Perl_croak(aTHX_ "seteuid() not implemented");
2472         }
2473 #endif
2474 #endif
2475 #endif
2476         PL_euid = PerlProc_geteuid();
2477         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2478         break;
2479     case '(':
2480         PL_gid = SvIV(sv);
2481         if (PL_delaymagic) {
2482             PL_delaymagic |= DM_RGID;
2483             break;                              /* don't do magic till later */
2484         }
2485 #ifdef HAS_SETRGID
2486         (void)setrgid((Gid_t)PL_gid);
2487 #else
2488 #ifdef HAS_SETREGID
2489         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2490 #else
2491 #ifdef HAS_SETRESGID
2492       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2493 #else
2494         if (PL_gid == PL_egid)                  /* special case $( = $) */
2495             (void)PerlProc_setgid(PL_gid);
2496         else {
2497             PL_gid = PerlProc_getgid();
2498             Perl_croak(aTHX_ "setrgid() not implemented");
2499         }
2500 #endif
2501 #endif
2502 #endif
2503         PL_gid = PerlProc_getgid();
2504         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2505         break;
2506     case ')':
2507 #ifdef HAS_SETGROUPS
2508         {
2509             const char *p = SvPV_const(sv, len);
2510             Groups_t *gary = NULL;
2511
2512             while (isSPACE(*p))
2513                 ++p;
2514             PL_egid = Atol(p);
2515             for (i = 0; i < NGROUPS; ++i) {
2516                 while (*p && !isSPACE(*p))
2517                     ++p;
2518                 while (isSPACE(*p))
2519                     ++p;
2520                 if (!*p)
2521                     break;
2522                 if(!gary)
2523                     Newx(gary, i + 1, Groups_t);
2524                 else
2525                     Renew(gary, i + 1, Groups_t);
2526                 gary[i] = Atol(p);
2527             }
2528             if (i)
2529                 (void)setgroups(i, gary);
2530             Safefree(gary);
2531         }
2532 #else  /* HAS_SETGROUPS */
2533         PL_egid = SvIV(sv);
2534 #endif /* HAS_SETGROUPS */
2535         if (PL_delaymagic) {
2536             PL_delaymagic |= DM_EGID;
2537             break;                              /* don't do magic till later */
2538         }
2539 #ifdef HAS_SETEGID
2540         (void)setegid((Gid_t)PL_egid);
2541 #else
2542 #ifdef HAS_SETREGID
2543         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2544 #else
2545 #ifdef HAS_SETRESGID
2546         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2547 #else
2548         if (PL_egid == PL_gid)                  /* special case $) = $( */
2549             (void)PerlProc_setgid(PL_egid);
2550         else {
2551             PL_egid = PerlProc_getegid();
2552             Perl_croak(aTHX_ "setegid() not implemented");
2553         }
2554 #endif
2555 #endif
2556 #endif
2557         PL_egid = PerlProc_getegid();
2558         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2559         break;
2560     case ':':
2561         PL_chopset = SvPV_force(sv,len);
2562         break;
2563 #ifndef MACOS_TRADITIONAL
2564     case '0':
2565         LOCK_DOLLARZERO_MUTEX;
2566 #ifdef HAS_SETPROCTITLE
2567         /* The BSDs don't show the argv[] in ps(1) output, they
2568          * show a string from the process struct and provide
2569          * the setproctitle() routine to manipulate that. */
2570         if (PL_origalen != 1) {
2571             s = SvPV_const(sv, len);
2572 #   if __FreeBSD_version > 410001
2573             /* The leading "-" removes the "perl: " prefix,
2574              * but not the "(perl) suffix from the ps(1)
2575              * output, because that's what ps(1) shows if the
2576              * argv[] is modified. */
2577             setproctitle("-%s", s);
2578 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2579             /* This doesn't really work if you assume that
2580              * $0 = 'foobar'; will wipe out 'perl' from the $0
2581              * because in ps(1) output the result will be like
2582              * sprintf("perl: %s (perl)", s)
2583              * I guess this is a security feature:
2584              * one (a user process) cannot get rid of the original name.
2585              * --jhi */
2586             setproctitle("%s", s);
2587 #   endif
2588         }
2589 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2590         if (PL_origalen != 1) {
2591              union pstun un;
2592              s = SvPV_const(sv, len);
2593              un.pst_command = (char *)s;
2594              pstat(PSTAT_SETCMD, un, len, 0, 0);
2595         }
2596 #else
2597         if (PL_origalen > 1) {
2598             /* PL_origalen is set in perl_parse(). */
2599             s = SvPV_force(sv,len);
2600             if (len >= (STRLEN)PL_origalen-1) {
2601                 /* Longer than original, will be truncated. We assume that
2602                  * PL_origalen bytes are available. */
2603                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2604             }
2605             else {
2606                 /* Shorter than original, will be padded. */
2607 #ifdef PERL_DARWIN
2608                 /* Special case for Mac OS X: see [perl #38868] */
2609                 const int pad = 0;
2610 #else
2611                 /* Is the space counterintuitive?  Yes.
2612                  * (You were expecting \0?)
2613                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2614                  * --jhi */
2615                 const int pad = ' ';
2616 #endif
2617                 Copy(s, PL_origargv[0], len, char);
2618                 PL_origargv[0][len] = 0;
2619                 memset(PL_origargv[0] + len + 1,
2620                        pad,  PL_origalen - len - 1);
2621             }
2622             PL_origargv[0][PL_origalen-1] = 0;
2623             for (i = 1; i < PL_origargc; i++)
2624                 PL_origargv[i] = 0;
2625         }
2626 #endif
2627         UNLOCK_DOLLARZERO_MUTEX;
2628         break;
2629 #endif
2630     }
2631     return 0;
2632 }
2633
2634 I32
2635 Perl_whichsig(pTHX_ const char *sig)
2636 {
2637     register char* const* sigv;
2638     PERL_UNUSED_CONTEXT;
2639
2640     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2641         if (strEQ(sig,*sigv))
2642             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2643 #ifdef SIGCLD
2644     if (strEQ(sig,"CHLD"))
2645         return SIGCLD;
2646 #endif
2647 #ifdef SIGCHLD
2648     if (strEQ(sig,"CLD"))
2649         return SIGCHLD;
2650 #endif
2651     return -1;
2652 }
2653
2654 Signal_t
2655 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2656 Perl_sighandler(int sig, ...)
2657 #else
2658 Perl_sighandler(int sig)
2659 #endif
2660 {
2661 #ifdef PERL_GET_SIG_CONTEXT
2662     dTHXa(PERL_GET_SIG_CONTEXT);
2663 #else
2664     dTHX;
2665 #endif
2666     dSP;
2667     GV *gv = NULL;
2668     SV *sv = NULL;
2669     SV * const tSv = PL_Sv;
2670     CV *cv = NULL;
2671     OP *myop = PL_op;
2672     U32 flags = 0;
2673     XPV * const tXpv = PL_Xpv;
2674
2675     if (PL_savestack_ix + 15 <= PL_savestack_max)
2676         flags |= 1;
2677     if (PL_markstack_ptr < PL_markstack_max - 2)
2678         flags |= 4;
2679     if (PL_scopestack_ix < PL_scopestack_max - 3)
2680         flags |= 16;
2681
2682     if (!PL_psig_ptr[sig]) {
2683                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2684                                  PL_sig_name[sig]);
2685                 exit(sig);
2686         }
2687
2688     /* Max number of items pushed there is 3*n or 4. We cannot fix
2689        infinity, so we fix 4 (in fact 5): */
2690     if (flags & 1) {
2691         PL_savestack_ix += 5;           /* Protect save in progress. */
2692         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2693     }
2694     if (flags & 4)
2695         PL_markstack_ptr++;             /* Protect mark. */
2696     if (flags & 16)
2697         PL_scopestack_ix += 1;
2698     /* sv_2cv is too complicated, try a simpler variant first: */
2699     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2700         || SvTYPE(cv) != SVt_PVCV) {
2701         HV *st;
2702         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2703     }
2704
2705     if (!cv || !CvROOT(cv)) {
2706         if (ckWARN(WARN_SIGNAL))
2707             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2708                 PL_sig_name[sig], (gv ? GvENAME(gv)
2709                                 : ((cv && CvGV(cv))
2710                                    ? GvENAME(CvGV(cv))
2711                                    : "__ANON__")));
2712         goto cleanup;
2713     }
2714
2715     if(PL_psig_name[sig]) {
2716         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2717         flags |= 64;
2718 #if !defined(PERL_IMPLICIT_CONTEXT)
2719         PL_sig_sv = sv;
2720 #endif
2721     } else {
2722         sv = sv_newmortal();
2723         sv_setpv(sv,PL_sig_name[sig]);
2724     }
2725
2726     PUSHSTACKi(PERLSI_SIGNAL);
2727     PUSHMARK(SP);
2728     PUSHs(sv);
2729 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2730     {
2731          struct sigaction oact;
2732
2733          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2734               siginfo_t *sip;
2735               va_list args;
2736
2737               va_start(args, sig);
2738               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2739               if (sip) {
2740                    HV *sih = newHV();
2741                    SV *rv  = newRV_noinc((SV*)sih);
2742                    /* The siginfo fields signo, code, errno, pid, uid,
2743                     * addr, status, and band are defined by POSIX/SUSv3. */
2744                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2745                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2746 #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. */
2747                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2748                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2749                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2750                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2751                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2752                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2753 #endif
2754                    EXTEND(SP, 2);
2755                    PUSHs((SV*)rv);
2756                    PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2757               }
2758
2759               va_end(args);
2760          }
2761     }
2762 #endif
2763     PUTBACK;
2764
2765     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2766
2767     POPSTACK;
2768     if (SvTRUE(ERRSV)) {
2769 #ifndef PERL_MICRO
2770 #ifdef HAS_SIGPROCMASK
2771         /* Handler "died", for example to get out of a restart-able read().
2772          * Before we re-do that on its behalf re-enable the signal which was
2773          * blocked by the system when we entered.
2774          */
2775         sigset_t set;
2776         sigemptyset(&set);
2777         sigaddset(&set,sig);
2778         sigprocmask(SIG_UNBLOCK, &set, NULL);
2779 #else
2780         /* Not clear if this will work */
2781         (void)rsignal(sig, SIG_IGN);
2782         (void)rsignal(sig, PL_csighandlerp);
2783 #endif
2784 #endif /* !PERL_MICRO */
2785         Perl_die(aTHX_ NULL);
2786     }
2787 cleanup:
2788     if (flags & 1)
2789         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2790     if (flags & 4)
2791         PL_markstack_ptr--;
2792     if (flags & 16)
2793         PL_scopestack_ix -= 1;
2794     if (flags & 64)
2795         SvREFCNT_dec(sv);
2796     PL_op = myop;                       /* Apparently not needed... */
2797
2798     PL_Sv = tSv;                        /* Restore global temporaries. */
2799     PL_Xpv = tXpv;
2800     return;
2801 }
2802
2803
2804 static void
2805 S_restore_magic(pTHX_ const void *p)
2806 {
2807     dVAR;
2808     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2809     SV* const sv = mgs->mgs_sv;
2810
2811     if (!sv)
2812         return;
2813
2814     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2815     {
2816 #ifdef PERL_OLD_COPY_ON_WRITE
2817         /* While magic was saved (and off) sv_setsv may well have seen
2818            this SV as a prime candidate for COW.  */
2819         if (SvIsCOW(sv))
2820             sv_force_normal_flags(sv, 0);
2821 #endif
2822
2823         if (mgs->mgs_flags)
2824             SvFLAGS(sv) |= mgs->mgs_flags;
2825         else
2826             mg_magical(sv);
2827         if (SvGMAGICAL(sv)) {
2828             /* downgrade public flags to private,
2829                and discard any other private flags */
2830
2831             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2832             if (pubflags) {
2833                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2834                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2835             }
2836         }
2837     }
2838
2839     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2840
2841     /* If we're still on top of the stack, pop us off.  (That condition
2842      * will be satisfied if restore_magic was called explicitly, but *not*
2843      * if it's being called via leave_scope.)
2844      * The reason for doing this is that otherwise, things like sv_2cv()
2845      * may leave alloc gunk on the savestack, and some code
2846      * (e.g. sighandler) doesn't expect that...
2847      */
2848     if (PL_savestack_ix == mgs->mgs_ss_ix)
2849     {
2850         I32 popval = SSPOPINT;
2851         assert(popval == SAVEt_DESTRUCTOR_X);
2852         PL_savestack_ix -= 2;
2853         popval = SSPOPINT;
2854         assert(popval == SAVEt_ALLOC);
2855         popval = SSPOPINT;
2856         PL_savestack_ix -= popval;
2857     }
2858
2859 }
2860
2861 static void
2862 S_unwind_handler_stack(pTHX_ const void *p)
2863 {
2864     dVAR;
2865     const U32 flags = *(const U32*)p;
2866
2867     if (flags & 1)
2868         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2869 #if !defined(PERL_IMPLICIT_CONTEXT)
2870     if (flags & 64)
2871         SvREFCNT_dec(PL_sig_sv);
2872 #endif
2873 }
2874
2875 /*
2876 =for apidoc magic_sethint
2877
2878 Triggered by a store to %^H, records the key/value pair to
2879 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
2880 anything that would need a deep copy.  Maybe we should warn if we find a
2881 reference.
2882
2883 =cut
2884 */
2885 int
2886 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2887 {
2888     dVAR;
2889     assert(mg->mg_len == HEf_SVKEY);
2890
2891     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
2892        an alternative leaf in there, with PL_compiling.cop_hints being used if
2893        it's NULL. If needed for threads, the alternative could lock a mutex,
2894        or take other more complex action.  */
2895
2896     /* Something changed in %^H, so it will need to be restored on scope exit.
2897        Doing this here saves a lot of doing it manually in perl code (and
2898        forgetting to do it, and consequent subtle errors.  */
2899     PL_hints |= HINT_LOCALIZE_HH;
2900     PL_compiling.cop_hints_hash
2901         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2902                                  (SV *)mg->mg_ptr, sv);
2903     return 0;
2904 }
2905
2906 /*
2907 =for apidoc magic_sethint
2908
2909 Triggered by a delete from %^H, records the key to
2910 C<PL_compiling.cop_hints_hash>.
2911
2912 =cut
2913 */
2914 int
2915 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2916 {
2917     dVAR;
2918     PERL_UNUSED_ARG(sv);
2919
2920     assert(mg->mg_len == HEf_SVKEY);
2921
2922     PERL_UNUSED_ARG(sv);
2923
2924     PL_hints |= HINT_LOCALIZE_HH;
2925     PL_compiling.cop_hints_hash
2926         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2927                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
2928     return 0;
2929 }
2930
2931 /*
2932  * Local variables:
2933  * c-indentation-style: bsd
2934  * c-basic-offset: 4
2935  * indent-tabs-mode: t
2936  * End:
2937  *
2938  * ex: set ts=8 sts=4 sw=4 noet:
2939  */