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