mg.c

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