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 #ifndef SIG_PENDING_DIE_COUNT
1282 #  define SIG_PENDING_DIE_COUNT 120
1283 #endif
1284
1285 static void
1286 S_raise_signal(pTHX_ int sig)
1287 {
1288     dVAR;
1289     /* Set a flag to say this signal is pending */
1290     PL_psig_pend[sig]++;
1291     /* And one to say _a_ signal is pending */
1292     if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1293         Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1294                 (unsigned long)SIG_PENDING_DIE_COUNT);
1295 }
1296
1297 Signal_t
1298 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1299 Perl_csighandler(int sig, ...)
1300 #else
1301 Perl_csighandler(int sig)
1302 #endif
1303 {
1304 #ifdef PERL_GET_SIG_CONTEXT
1305     dTHXa(PERL_GET_SIG_CONTEXT);
1306 #else
1307     dTHX;
1308 #endif
1309 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1310     (void) rsignal(sig, PL_csighandlerp);
1311     if (PL_sig_ignoring[sig]) return;
1312 #endif
1313 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1314     if (PL_sig_defaulting[sig])
1315 #ifdef KILL_BY_SIGPRC
1316             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1317 #else
1318             exit(1);
1319 #endif
1320 #endif
1321    if (
1322 #ifdef SIGILL
1323            sig == SIGILL ||
1324 #endif
1325 #ifdef SIGBUS
1326            sig == SIGBUS ||
1327 #endif
1328 #ifdef SIGSEGV
1329            sig == SIGSEGV ||
1330 #endif
1331            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1332         /* Call the perl level handler now--
1333          * with risk we may be in malloc() etc. */
1334         (*PL_sighandlerp)(sig);
1335    else
1336         S_raise_signal(aTHX_ sig);
1337 }
1338
1339 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1340 void
1341 Perl_csighandler_init(void)
1342 {
1343     int sig;
1344     if (PL_sig_handlers_initted) return;
1345
1346     for (sig = 1; sig < SIG_SIZE; sig++) {
1347 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1348         dTHX;
1349         PL_sig_defaulting[sig] = 1;
1350         (void) rsignal(sig, PL_csighandlerp);
1351 #endif
1352 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1353         PL_sig_ignoring[sig] = 0;
1354 #endif
1355     }
1356     PL_sig_handlers_initted = 1;
1357 }
1358 #endif
1359
1360 void
1361 Perl_despatch_signals(pTHX)
1362 {
1363     dVAR;
1364     int sig;
1365     PL_sig_pending = 0;
1366     for (sig = 1; sig < SIG_SIZE; sig++) {
1367         if (PL_psig_pend[sig]) {
1368             PERL_BLOCKSIG_ADD(set, sig);
1369             PL_psig_pend[sig] = 0;
1370             PERL_BLOCKSIG_BLOCK(set);
1371             (*PL_sighandlerp)(sig);
1372             PERL_BLOCKSIG_UNBLOCK(set);
1373         }
1374     }
1375 }
1376
1377 int
1378 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1379 {
1380     dVAR;
1381     I32 i;
1382     SV** svp = NULL;
1383     /* Need to be careful with SvREFCNT_dec(), because that can have side
1384      * effects (due to closures). We must make sure that the new disposition
1385      * is in place before it is called.
1386      */
1387     SV* to_dec = NULL;
1388     STRLEN len;
1389 #ifdef HAS_SIGPROCMASK
1390     sigset_t set, save;
1391     SV* save_sv;
1392 #endif
1393
1394     register const char *s = MgPV_const(mg,len);
1395     if (*s == '_') {
1396         if (strEQ(s,"__DIE__"))
1397             svp = &PL_diehook;
1398         else if (strEQ(s,"__WARN__"))
1399             svp = &PL_warnhook;
1400         else
1401             Perl_croak(aTHX_ "No such hook: %s", s);
1402         i = 0;
1403         if (*svp) {
1404             if (*svp != PERL_WARNHOOK_FATAL)
1405                 to_dec = *svp;
1406             *svp = NULL;
1407         }
1408     }
1409     else {
1410         i = whichsig(s);        /* ...no, a brick */
1411         if (i <= 0) {
1412             if (ckWARN(WARN_SIGNAL))
1413                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1414             return 0;
1415         }
1416 #ifdef HAS_SIGPROCMASK
1417         /* Avoid having the signal arrive at a bad time, if possible. */
1418         sigemptyset(&set);
1419         sigaddset(&set,i);
1420         sigprocmask(SIG_BLOCK, &set, &save);
1421         ENTER;
1422         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1423         SAVEFREESV(save_sv);
1424         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1425 #endif
1426         PERL_ASYNC_CHECK();
1427 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1428         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1429 #endif
1430 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1431         PL_sig_ignoring[i] = 0;
1432 #endif
1433 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1434         PL_sig_defaulting[i] = 0;
1435 #endif
1436         SvREFCNT_dec(PL_psig_name[i]);
1437         to_dec = PL_psig_ptr[i];
1438         PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1439         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1440         PL_psig_name[i] = newSVpvn(s, len);
1441         SvREADONLY_on(PL_psig_name[i]);
1442     }
1443     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1444         if (i) {
1445             (void)rsignal(i, PL_csighandlerp);
1446 #ifdef HAS_SIGPROCMASK
1447             LEAVE;
1448 #endif
1449         }
1450         else
1451             *svp = SvREFCNT_inc_simple_NN(sv);
1452         if(to_dec)
1453             SvREFCNT_dec(to_dec);
1454         return 0;
1455     }
1456     s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1457     if (strEQ(s,"IGNORE")) {
1458         if (i) {
1459 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1460             PL_sig_ignoring[i] = 1;
1461             (void)rsignal(i, PL_csighandlerp);
1462 #else
1463             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1464 #endif
1465         }
1466     }
1467     else if (strEQ(s,"DEFAULT") || !*s) {
1468         if (i)
1469 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1470           {
1471             PL_sig_defaulting[i] = 1;
1472             (void)rsignal(i, PL_csighandlerp);
1473           }
1474 #else
1475             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1476 #endif
1477     }
1478     else {
1479         /*
1480          * We should warn if HINT_STRICT_REFS, but without
1481          * access to a known hint bit in a known OP, we can't
1482          * tell whether HINT_STRICT_REFS is in force or not.
1483          */
1484         if (!strchr(s,':') && !strchr(s,'\''))
1485             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1486         if (i)
1487             (void)rsignal(i, PL_csighandlerp);
1488         else
1489             *svp = SvREFCNT_inc_simple_NN(sv);
1490     }
1491 #ifdef HAS_SIGPROCMASK
1492     if(i)
1493         LEAVE;
1494 #endif
1495     if(to_dec)
1496         SvREFCNT_dec(to_dec);
1497     return 0;
1498 }
1499 #endif /* !PERL_MICRO */
1500
1501 int
1502 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1503 {
1504     dVAR;
1505     PERL_UNUSED_ARG(sv);
1506     PERL_UNUSED_ARG(mg);
1507     PL_sub_generation++;
1508     return 0;
1509 }
1510
1511 int
1512 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1513 {
1514     dVAR;
1515     PERL_UNUSED_ARG(sv);
1516     PERL_UNUSED_ARG(mg);
1517     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1518     PL_amagic_generation++;
1519
1520     return 0;
1521 }
1522
1523 int
1524 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1525 {
1526     HV * const hv = (HV*)LvTARG(sv);
1527     I32 i = 0;
1528     PERL_UNUSED_ARG(mg);
1529
1530     if (hv) {
1531          (void) hv_iterinit(hv);
1532          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1533              i = HvKEYS(hv);
1534          else {
1535              while (hv_iternext(hv))
1536                  i++;
1537          }
1538     }
1539
1540     sv_setiv(sv, (IV)i);
1541     return 0;
1542 }
1543
1544 int
1545 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1546 {
1547     PERL_UNUSED_ARG(mg);
1548     if (LvTARG(sv)) {
1549         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1550     }
1551     return 0;
1552 }
1553
1554 /* caller is responsible for stack switching/cleanup */
1555 STATIC int
1556 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1557 {
1558     dVAR;
1559     dSP;
1560
1561     PUSHMARK(SP);
1562     EXTEND(SP, n);
1563     PUSHs(SvTIED_obj(sv, mg));
1564     if (n > 1) {
1565         if (mg->mg_ptr) {
1566             if (mg->mg_len >= 0)
1567                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1568             else if (mg->mg_len == HEf_SVKEY)
1569                 PUSHs((SV*)mg->mg_ptr);
1570         }
1571         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1572             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1573         }
1574     }
1575     if (n > 2) {
1576         PUSHs(val);
1577     }
1578     PUTBACK;
1579
1580     return call_method(meth, flags);
1581 }
1582
1583 STATIC int
1584 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1585 {
1586     dVAR; dSP;
1587
1588     ENTER;
1589     SAVETMPS;
1590     PUSHSTACKi(PERLSI_MAGIC);
1591
1592     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1593         sv_setsv(sv, *PL_stack_sp--);
1594     }
1595
1596     POPSTACK;
1597     FREETMPS;
1598     LEAVE;
1599     return 0;
1600 }
1601
1602 int
1603 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1604 {
1605     if (mg->mg_ptr)
1606         mg->mg_flags |= MGf_GSKIP;
1607     magic_methpack(sv,mg,"FETCH");
1608     return 0;
1609 }
1610
1611 int
1612 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1613 {
1614     dVAR; dSP;
1615     ENTER;
1616     PUSHSTACKi(PERLSI_MAGIC);
1617     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1618     POPSTACK;
1619     LEAVE;
1620     return 0;
1621 }
1622
1623 int
1624 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1625 {
1626     return magic_methpack(sv,mg,"DELETE");
1627 }
1628
1629
1630 U32
1631 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1632 {
1633     dVAR; dSP;
1634     U32 retval = 0;
1635
1636     ENTER;
1637     SAVETMPS;
1638     PUSHSTACKi(PERLSI_MAGIC);
1639     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1640         sv = *PL_stack_sp--;
1641         retval = (U32) SvIV(sv)-1;
1642     }
1643     POPSTACK;
1644     FREETMPS;
1645     LEAVE;
1646     return retval;
1647 }
1648
1649 int
1650 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1651 {
1652     dVAR; dSP;
1653
1654     ENTER;
1655     PUSHSTACKi(PERLSI_MAGIC);
1656     PUSHMARK(SP);
1657     XPUSHs(SvTIED_obj(sv, mg));
1658     PUTBACK;
1659     call_method("CLEAR", G_SCALAR|G_DISCARD);
1660     POPSTACK;
1661     LEAVE;
1662
1663     return 0;
1664 }
1665
1666 int
1667 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1668 {
1669     dVAR; dSP;
1670     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1671
1672     ENTER;
1673     SAVETMPS;
1674     PUSHSTACKi(PERLSI_MAGIC);
1675     PUSHMARK(SP);
1676     EXTEND(SP, 2);
1677     PUSHs(SvTIED_obj(sv, mg));
1678     if (SvOK(key))
1679         PUSHs(key);
1680     PUTBACK;
1681
1682     if (call_method(meth, G_SCALAR))
1683         sv_setsv(key, *PL_stack_sp--);
1684
1685     POPSTACK;
1686     FREETMPS;
1687     LEAVE;
1688     return 0;
1689 }
1690
1691 int
1692 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1693 {
1694     return magic_methpack(sv,mg,"EXISTS");
1695 }
1696
1697 SV *
1698 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1699 {
1700     dVAR; dSP;
1701     SV *retval;
1702     SV * const tied = SvTIED_obj((SV*)hv, mg);
1703     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1704
1705     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1706         SV *key;
1707         if (HvEITER_get(hv))
1708             /* we are in an iteration so the hash cannot be empty */
1709             return &PL_sv_yes;
1710         /* no xhv_eiter so now use FIRSTKEY */
1711         key = sv_newmortal();
1712         magic_nextpack((SV*)hv, mg, key);
1713         HvEITER_set(hv, NULL);     /* need to reset iterator */
1714         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1715     }
1716
1717     /* there is a SCALAR method that we can call */
1718     ENTER;
1719     PUSHSTACKi(PERLSI_MAGIC);
1720     PUSHMARK(SP);
1721     EXTEND(SP, 1);
1722     PUSHs(tied);
1723     PUTBACK;
1724
1725     if (call_method("SCALAR", G_SCALAR))
1726         retval = *PL_stack_sp--;
1727     else
1728         retval = &PL_sv_undef;
1729     POPSTACK;
1730     LEAVE;
1731     return retval;
1732 }
1733
1734 int
1735 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1736 {
1737     dVAR;
1738     GV * const gv = PL_DBline;
1739     const I32 i = SvTRUE(sv);
1740     SV ** const svp = av_fetch(GvAV(gv),
1741                      atoi(MgPV_nolen_const(mg)), FALSE);
1742     if (svp && SvIOKp(*svp)) {
1743         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1744         if (o) {
1745             /* set or clear breakpoint in the relevant control op */
1746             if (i)
1747                 o->op_flags |= OPf_SPECIAL;
1748             else
1749                 o->op_flags &= ~OPf_SPECIAL;
1750         }
1751     }
1752     return 0;
1753 }
1754
1755 int
1756 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1757 {
1758     dVAR;
1759     const AV * const obj = (AV*)mg->mg_obj;
1760     if (obj) {
1761         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1762     } else {
1763         SvOK_off(sv);
1764     }
1765     return 0;
1766 }
1767
1768 int
1769 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1770 {
1771     dVAR;
1772     AV * const obj = (AV*)mg->mg_obj;
1773     if (obj) {
1774         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1775     } else {
1776         if (ckWARN(WARN_MISC))
1777             Perl_warner(aTHX_ packWARN(WARN_MISC),
1778                         "Attempt to set length of freed array");
1779     }
1780     return 0;
1781 }
1782
1783 int
1784 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1785 {
1786     dVAR;
1787     PERL_UNUSED_ARG(sv);
1788     /* during global destruction, mg_obj may already have been freed */
1789     if (PL_in_clean_all)
1790         return 0;
1791
1792     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1793
1794     if (mg) {
1795         /* arylen scalar holds a pointer back to the array, but doesn't own a
1796            reference. Hence the we (the array) are about to go away with it
1797            still pointing at us. Clear its pointer, else it would be pointing
1798            at free memory. See the comment in sv_magic about reference loops,
1799            and why it can't own a reference to us.  */
1800         mg->mg_obj = 0;
1801     }
1802     return 0;
1803 }
1804
1805 int
1806 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1807 {
1808     dVAR;
1809     SV* const lsv = LvTARG(sv);
1810     PERL_UNUSED_ARG(mg);
1811
1812     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1813         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1814         if (found && found->mg_len >= 0) {
1815             I32 i = found->mg_len;
1816             if (DO_UTF8(lsv))
1817                 sv_pos_b2u(lsv, &i);
1818             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1819             return 0;
1820         }
1821     }
1822     SvOK_off(sv);
1823     return 0;
1824 }
1825
1826 int
1827 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1828 {
1829     dVAR;
1830     SV* const lsv = LvTARG(sv);
1831     SSize_t pos;
1832     STRLEN len;
1833     STRLEN ulen = 0;
1834     MAGIC* found;
1835
1836     PERL_UNUSED_ARG(mg);
1837
1838     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1839         found = mg_find(lsv, PERL_MAGIC_regex_global);
1840     else
1841         found = NULL;
1842     if (!found) {
1843         if (!SvOK(sv))
1844             return 0;
1845 #ifdef PERL_OLD_COPY_ON_WRITE
1846     if (SvIsCOW(lsv))
1847         sv_force_normal_flags(lsv, 0);
1848 #endif
1849         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1850                             NULL, 0);
1851     }
1852     else if (!SvOK(sv)) {
1853         found->mg_len = -1;
1854         return 0;
1855     }
1856     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1857
1858     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1859
1860     if (DO_UTF8(lsv)) {
1861         ulen = sv_len_utf8(lsv);
1862         if (ulen)
1863             len = ulen;
1864     }
1865
1866     if (pos < 0) {
1867         pos += len;
1868         if (pos < 0)
1869             pos = 0;
1870     }
1871     else if (pos > (SSize_t)len)
1872         pos = len;
1873
1874     if (ulen) {
1875         I32 p = pos;
1876         sv_pos_u2b(lsv, &p, 0);
1877         pos = p;
1878     }
1879
1880     found->mg_len = pos;
1881     found->mg_flags &= ~MGf_MINMATCH;
1882
1883     return 0;
1884 }
1885
1886 int
1887 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1888 {
1889     GV* gv;
1890     PERL_UNUSED_ARG(mg);
1891
1892     if (!SvOK(sv))
1893         return 0;
1894     if (isGV_with_GP(sv)) {
1895         /* We're actually already a typeglob, so don't need the stuff below.
1896          */
1897         return 0;
1898     }
1899     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1900     if (sv == (SV*)gv)
1901         return 0;
1902     if (GvGP(sv))
1903         gp_free((GV*)sv);
1904     GvGP(sv) = gp_ref(GvGP(gv));
1905     return 0;
1906 }
1907
1908 int
1909 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1910 {
1911     STRLEN len;
1912     SV * const lsv = LvTARG(sv);
1913     const char * const tmps = SvPV_const(lsv,len);
1914     I32 offs = LvTARGOFF(sv);
1915     I32 rem = LvTARGLEN(sv);
1916     PERL_UNUSED_ARG(mg);
1917
1918     if (SvUTF8(lsv))
1919         sv_pos_u2b(lsv, &offs, &rem);
1920     if (offs > (I32)len)
1921         offs = len;
1922     if (rem + offs > (I32)len)
1923         rem = len - offs;
1924     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1925     if (SvUTF8(lsv))
1926         SvUTF8_on(sv);
1927     return 0;
1928 }
1929
1930 int
1931 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1932 {
1933     dVAR;
1934     STRLEN len;
1935     const char * const tmps = SvPV_const(sv, len);
1936     SV * const lsv = LvTARG(sv);
1937     I32 lvoff = LvTARGOFF(sv);
1938     I32 lvlen = LvTARGLEN(sv);
1939     PERL_UNUSED_ARG(mg);
1940
1941     if (DO_UTF8(sv)) {
1942         sv_utf8_upgrade(lsv);
1943         sv_pos_u2b(lsv, &lvoff, &lvlen);
1944         sv_insert(lsv, lvoff, lvlen, tmps, len);
1945         LvTARGLEN(sv) = sv_len_utf8(sv);
1946         SvUTF8_on(lsv);
1947     }
1948     else if (lsv && SvUTF8(lsv)) {
1949         const char *utf8;
1950         sv_pos_u2b(lsv, &lvoff, &lvlen);
1951         LvTARGLEN(sv) = len;
1952         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1953         sv_insert(lsv, lvoff, lvlen, utf8, len);
1954         Safefree(utf8);
1955     }
1956     else {
1957         sv_insert(lsv, lvoff, lvlen, tmps, len);
1958         LvTARGLEN(sv) = len;
1959     }
1960
1961
1962     return 0;
1963 }
1964
1965 int
1966 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1967 {
1968     dVAR;
1969     PERL_UNUSED_ARG(sv);
1970     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1971     return 0;
1972 }
1973
1974 int
1975 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1976 {
1977     dVAR;
1978     PERL_UNUSED_ARG(sv);
1979     /* update taint status unless we're restoring at scope exit */
1980     if (PL_localizing != 2) {
1981         if (PL_tainted)
1982             mg->mg_len |= 1;
1983         else
1984             mg->mg_len &= ~1;
1985     }
1986     return 0;
1987 }
1988
1989 int
1990 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1991 {
1992     SV * const lsv = LvTARG(sv);
1993     PERL_UNUSED_ARG(mg);
1994
1995     if (lsv)
1996         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1997     else
1998         SvOK_off(sv);
1999
2000     return 0;
2001 }
2002
2003 int
2004 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2005 {
2006     PERL_UNUSED_ARG(mg);
2007     do_vecset(sv);      /* XXX slurp this routine */
2008     return 0;
2009 }
2010
2011 int
2012 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2013 {
2014     dVAR;
2015     SV *targ = NULL;
2016     if (LvTARGLEN(sv)) {
2017         if (mg->mg_obj) {
2018             SV * const ahv = LvTARG(sv);
2019             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2020             if (he)
2021                 targ = HeVAL(he);
2022         }
2023         else {
2024             AV* const av = (AV*)LvTARG(sv);
2025             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2026                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2027         }
2028         if (targ && (targ != &PL_sv_undef)) {
2029             /* somebody else defined it for us */
2030             SvREFCNT_dec(LvTARG(sv));
2031             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2032             LvTARGLEN(sv) = 0;
2033             SvREFCNT_dec(mg->mg_obj);
2034             mg->mg_obj = NULL;
2035             mg->mg_flags &= ~MGf_REFCOUNTED;
2036         }
2037     }
2038     else
2039         targ = LvTARG(sv);
2040     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2041     return 0;
2042 }
2043
2044 int
2045 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2046 {
2047     PERL_UNUSED_ARG(mg);
2048     if (LvTARGLEN(sv))
2049         vivify_defelem(sv);
2050     if (LvTARG(sv)) {
2051         sv_setsv(LvTARG(sv), sv);
2052         SvSETMAGIC(LvTARG(sv));
2053     }
2054     return 0;
2055 }
2056
2057 void
2058 Perl_vivify_defelem(pTHX_ SV *sv)
2059 {
2060     dVAR;
2061     MAGIC *mg;
2062     SV *value = NULL;
2063
2064     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2065         return;
2066     if (mg->mg_obj) {
2067         SV * const ahv = LvTARG(sv);
2068         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2069         if (he)
2070             value = HeVAL(he);
2071         if (!value || value == &PL_sv_undef)
2072             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2073     }
2074     else {
2075         AV* const av = (AV*)LvTARG(sv);
2076         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2077             LvTARG(sv) = NULL;  /* array can't be extended */
2078         else {
2079             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2080             if (!svp || (value = *svp) == &PL_sv_undef)
2081                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2082         }
2083     }
2084     SvREFCNT_inc_simple_void(value);
2085     SvREFCNT_dec(LvTARG(sv));
2086     LvTARG(sv) = value;
2087     LvTARGLEN(sv) = 0;
2088     SvREFCNT_dec(mg->mg_obj);
2089     mg->mg_obj = NULL;
2090     mg->mg_flags &= ~MGf_REFCOUNTED;
2091 }
2092
2093 int
2094 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2095 {
2096     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2097 }
2098
2099 int
2100 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2101 {
2102     PERL_UNUSED_CONTEXT;
2103     mg->mg_len = -1;
2104     SvSCREAM_off(sv);
2105     return 0;
2106 }
2107
2108 int
2109 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2110 {
2111     PERL_UNUSED_ARG(mg);
2112     sv_unmagic(sv, PERL_MAGIC_bm);
2113     SvTAIL_off(sv);
2114     SvVALID_off(sv);
2115     return 0;
2116 }
2117
2118 int
2119 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2120 {
2121     PERL_UNUSED_ARG(mg);
2122     sv_unmagic(sv, PERL_MAGIC_fm);
2123     SvCOMPILED_off(sv);
2124     return 0;
2125 }
2126
2127 int
2128 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2129 {
2130     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2131
2132     if (uf && uf->uf_set)
2133         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2134     return 0;
2135 }
2136
2137 int
2138 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2139 {
2140     PERL_UNUSED_ARG(mg);
2141     sv_unmagic(sv, PERL_MAGIC_qr);
2142     return 0;
2143 }
2144
2145 int
2146 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2147 {
2148     dVAR;
2149     regexp * const re = (regexp *)mg->mg_obj;
2150     PERL_UNUSED_ARG(sv);
2151
2152     ReREFCNT_dec(re);
2153     return 0;
2154 }
2155
2156 #ifdef USE_LOCALE_COLLATE
2157 int
2158 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2159 {
2160     /*
2161      * RenE<eacute> Descartes said "I think not."
2162      * and vanished with a faint plop.
2163      */
2164     PERL_UNUSED_CONTEXT;
2165     PERL_UNUSED_ARG(sv);
2166     if (mg->mg_ptr) {
2167         Safefree(mg->mg_ptr);
2168         mg->mg_ptr = NULL;
2169         mg->mg_len = -1;
2170     }
2171     return 0;
2172 }
2173 #endif /* USE_LOCALE_COLLATE */
2174
2175 /* Just clear the UTF-8 cache data. */
2176 int
2177 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2178 {
2179     PERL_UNUSED_CONTEXT;
2180     PERL_UNUSED_ARG(sv);
2181     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2182     mg->mg_ptr = NULL;
2183     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2184     return 0;
2185 }
2186
2187 int
2188 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2189 {
2190     dVAR;
2191     register const char *s;
2192     I32 i;
2193     STRLEN len;
2194     switch (*mg->mg_ptr) {
2195     case '\001':        /* ^A */
2196         sv_setsv(PL_bodytarget, sv);
2197         break;
2198     case '\003':        /* ^C */
2199         PL_minus_c = (bool)SvIV(sv);
2200         break;
2201
2202     case '\004':        /* ^D */
2203 #ifdef DEBUGGING
2204         s = SvPV_nolen_const(sv);
2205         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2206         DEBUG_x(dump_all());
2207 #else
2208         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2209 #endif
2210         break;
2211     case '\005':  /* ^E */
2212         if (*(mg->mg_ptr+1) == '\0') {
2213 #ifdef MACOS_TRADITIONAL
2214             gMacPerl_OSErr = SvIV(sv);
2215 #else
2216 #  ifdef VMS
2217             set_vaxc_errno(SvIV(sv));
2218 #  else
2219 #    ifdef WIN32
2220             SetLastError( SvIV(sv) );
2221 #    else
2222 #      ifdef OS2
2223             os2_setsyserrno(SvIV(sv));
2224 #      else
2225             /* will anyone ever use this? */
2226             SETERRNO(SvIV(sv), 4);
2227 #      endif
2228 #    endif
2229 #  endif
2230 #endif
2231         }
2232         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2233             if (PL_encoding)
2234                 SvREFCNT_dec(PL_encoding);
2235             if (SvOK(sv) || SvGMAGICAL(sv)) {
2236                 PL_encoding = newSVsv(sv);
2237             }
2238             else {
2239                 PL_encoding = NULL;
2240             }
2241         }
2242         break;
2243     case '\006':        /* ^F */
2244         PL_maxsysfd = SvIV(sv);
2245         break;
2246     case '\010':        /* ^H */
2247         PL_hints = SvIV(sv);
2248         break;
2249     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2250         Safefree(PL_inplace);
2251         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2252         break;
2253     case '\017':        /* ^O */
2254         if (*(mg->mg_ptr+1) == '\0') {
2255             Safefree(PL_osname);
2256             PL_osname = NULL;
2257             if (SvOK(sv)) {
2258                 TAINT_PROPER("assigning to $^O");
2259                 PL_osname = savesvpv(sv);
2260             }
2261         }
2262         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2263             STRLEN len;
2264             const char *const start = SvPV(sv, len);
2265             const char *out = memchr(start, '\0', len);
2266             SV *tmp;
2267             struct refcounted_he *tmp_he;
2268
2269
2270             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2271             PL_hints
2272                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2273
2274             /* Opening for input is more common than opening for output, so
2275                ensure that hints for input are sooner on linked list.  */
2276             tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2277                              : newSVpvs(""));
2278             SvFLAGS(tmp) |= SvUTF8(sv);
2279
2280             tmp_he
2281                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2282                                          sv_2mortal(newSVpvs("open>")), tmp);
2283
2284             /* The UTF-8 setting is carried over  */
2285             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2286
2287             PL_compiling.cop_hints_hash
2288                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2289                                          sv_2mortal(newSVpvs("open<")), tmp);
2290         }
2291         break;
2292     case '\020':        /* ^P */
2293         PL_perldb = SvIV(sv);
2294         if (PL_perldb && !PL_DBsingle)
2295             init_debugger();
2296         break;
2297     case '\024':        /* ^T */
2298 #ifdef BIG_TIME
2299         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2300 #else
2301         PL_basetime = (Time_t)SvIV(sv);
2302 #endif
2303         break;
2304     case '\025':        /* ^UTF8CACHE */
2305          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2306              PL_utf8cache = (signed char) sv_2iv(sv);
2307          }
2308          break;
2309     case '\027':        /* ^W & $^WARNING_BITS */
2310         if (*(mg->mg_ptr+1) == '\0') {
2311             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2312                 i = SvIV(sv);
2313                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2314                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2315             }
2316         }
2317         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2318             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2319                 if (!SvPOK(sv) && PL_localizing) {
2320                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2321                     PL_compiling.cop_warnings = pWARN_NONE;
2322                     break;
2323                 }
2324                 {
2325                     STRLEN len, i;
2326                     int accumulate = 0 ;
2327                     int any_fatals = 0 ;
2328                     const char * const ptr = SvPV_const(sv, len) ;
2329                     for (i = 0 ; i < len ; ++i) {
2330                         accumulate |= ptr[i] ;
2331                         any_fatals |= (ptr[i] & 0xAA) ;
2332                     }
2333                     if (!accumulate) {
2334                         if (!specialWARN(PL_compiling.cop_warnings))
2335                             PerlMemShared_free(PL_compiling.cop_warnings);
2336                         PL_compiling.cop_warnings = pWARN_NONE;
2337                     }
2338                     /* Yuck. I can't see how to abstract this:  */
2339                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2340                                        WARN_ALL) && !any_fatals) {
2341                         if (!specialWARN(PL_compiling.cop_warnings))
2342                             PerlMemShared_free(PL_compiling.cop_warnings);
2343                         PL_compiling.cop_warnings = pWARN_ALL;
2344                         PL_dowarn |= G_WARN_ONCE ;
2345                     }
2346                     else {
2347                         STRLEN len;
2348                         const char *const p = SvPV_const(sv, len);
2349
2350                         PL_compiling.cop_warnings
2351                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2352                                                          p, len);
2353
2354                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2355                             PL_dowarn |= G_WARN_ONCE ;
2356                     }
2357
2358                 }
2359             }
2360         }
2361         break;
2362     case '.':
2363         if (PL_localizing) {
2364             if (PL_localizing == 1)
2365                 SAVESPTR(PL_last_in_gv);
2366         }
2367         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2368             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2369         break;
2370     case '^':
2371         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2372         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2373         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2374         break;
2375     case '~':
2376         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2377         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2378         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2379         break;
2380     case '=':
2381         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2382         break;
2383     case '-':
2384         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2385         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2386             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2387         break;
2388     case '%':
2389         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2390         break;
2391     case '|':
2392         {
2393             IO * const io = GvIOp(PL_defoutgv);
2394             if(!io)
2395               break;
2396             if ((SvIV(sv)) == 0)
2397                 IoFLAGS(io) &= ~IOf_FLUSH;
2398             else {
2399                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2400                     PerlIO *ofp = IoOFP(io);
2401                     if (ofp)
2402                         (void)PerlIO_flush(ofp);
2403                     IoFLAGS(io) |= IOf_FLUSH;
2404                 }
2405             }
2406         }
2407         break;
2408     case '/':
2409         SvREFCNT_dec(PL_rs);
2410         PL_rs = newSVsv(sv);
2411         break;
2412     case '\\':
2413         if (PL_ors_sv)
2414             SvREFCNT_dec(PL_ors_sv);
2415         if (SvOK(sv) || SvGMAGICAL(sv)) {
2416             PL_ors_sv = newSVsv(sv);
2417         }
2418         else {
2419             PL_ors_sv = NULL;
2420         }
2421         break;
2422     case ',':
2423         if (PL_ofs_sv)
2424             SvREFCNT_dec(PL_ofs_sv);
2425         if (SvOK(sv) || SvGMAGICAL(sv)) {
2426             PL_ofs_sv = newSVsv(sv);
2427         }
2428         else {
2429             PL_ofs_sv = NULL;
2430         }
2431         break;
2432     case '[':
2433         CopARYBASE_set(&PL_compiling, SvIV(sv));
2434         break;
2435     case '?':
2436 #ifdef COMPLEX_STATUS
2437         if (PL_localizing == 2) {
2438             PL_statusvalue = LvTARGOFF(sv);
2439             PL_statusvalue_vms = LvTARGLEN(sv);
2440         }
2441         else
2442 #endif
2443 #ifdef VMSISH_STATUS
2444         if (VMSISH_STATUS)
2445             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2446         else
2447 #endif
2448             STATUS_UNIX_EXIT_SET(SvIV(sv));
2449         break;
2450     case '!':
2451         {
2452 #ifdef VMS
2453 #   define PERL_VMS_BANG vaxc$errno
2454 #else
2455 #   define PERL_VMS_BANG 0
2456 #endif
2457         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2458                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2459         }
2460         break;
2461     case '<':
2462         PL_uid = SvIV(sv);
2463         if (PL_delaymagic) {
2464             PL_delaymagic |= DM_RUID;
2465             break;                              /* don't do magic till later */
2466         }
2467 #ifdef HAS_SETRUID
2468         (void)setruid((Uid_t)PL_uid);
2469 #else
2470 #ifdef HAS_SETREUID
2471         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2472 #else
2473 #ifdef HAS_SETRESUID
2474       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2475 #else
2476         if (PL_uid == PL_euid) {                /* special case $< = $> */
2477 #ifdef PERL_DARWIN
2478             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2479             if (PL_uid != 0 && PerlProc_getuid() == 0)
2480                 (void)PerlProc_setuid(0);
2481 #endif
2482             (void)PerlProc_setuid(PL_uid);
2483         } else {
2484             PL_uid = PerlProc_getuid();
2485             Perl_croak(aTHX_ "setruid() not implemented");
2486         }
2487 #endif
2488 #endif
2489 #endif
2490         PL_uid = PerlProc_getuid();
2491         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2492         break;
2493     case '>':
2494         PL_euid = SvIV(sv);
2495         if (PL_delaymagic) {
2496             PL_delaymagic |= DM_EUID;
2497             break;                              /* don't do magic till later */
2498         }
2499 #ifdef HAS_SETEUID
2500         (void)seteuid((Uid_t)PL_euid);
2501 #else
2502 #ifdef HAS_SETREUID
2503         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2504 #else
2505 #ifdef HAS_SETRESUID
2506         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2507 #else
2508         if (PL_euid == PL_uid)          /* special case $> = $< */
2509             PerlProc_setuid(PL_euid);
2510         else {
2511             PL_euid = PerlProc_geteuid();
2512             Perl_croak(aTHX_ "seteuid() not implemented");
2513         }
2514 #endif
2515 #endif
2516 #endif
2517         PL_euid = PerlProc_geteuid();
2518         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2519         break;
2520     case '(':
2521         PL_gid = SvIV(sv);
2522         if (PL_delaymagic) {
2523             PL_delaymagic |= DM_RGID;
2524             break;                              /* don't do magic till later */
2525         }
2526 #ifdef HAS_SETRGID
2527         (void)setrgid((Gid_t)PL_gid);
2528 #else
2529 #ifdef HAS_SETREGID
2530         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2531 #else
2532 #ifdef HAS_SETRESGID
2533       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2534 #else
2535         if (PL_gid == PL_egid)                  /* special case $( = $) */
2536             (void)PerlProc_setgid(PL_gid);
2537         else {
2538             PL_gid = PerlProc_getgid();
2539             Perl_croak(aTHX_ "setrgid() not implemented");
2540         }
2541 #endif
2542 #endif
2543 #endif
2544         PL_gid = PerlProc_getgid();
2545         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2546         break;
2547     case ')':
2548 #ifdef HAS_SETGROUPS
2549         {
2550             const char *p = SvPV_const(sv, len);
2551             Groups_t *gary = NULL;
2552
2553             while (isSPACE(*p))
2554                 ++p;
2555             PL_egid = Atol(p);
2556             for (i = 0; i < NGROUPS; ++i) {
2557                 while (*p && !isSPACE(*p))
2558                     ++p;
2559                 while (isSPACE(*p))
2560                     ++p;
2561                 if (!*p)
2562                     break;
2563                 if(!gary)
2564                     Newx(gary, i + 1, Groups_t);
2565                 else
2566                     Renew(gary, i + 1, Groups_t);
2567                 gary[i] = Atol(p);
2568             }
2569             if (i)
2570                 (void)setgroups(i, gary);
2571             Safefree(gary);
2572         }
2573 #else  /* HAS_SETGROUPS */
2574         PL_egid = SvIV(sv);
2575 #endif /* HAS_SETGROUPS */
2576         if (PL_delaymagic) {
2577             PL_delaymagic |= DM_EGID;
2578             break;                              /* don't do magic till later */
2579         }
2580 #ifdef HAS_SETEGID
2581         (void)setegid((Gid_t)PL_egid);
2582 #else
2583 #ifdef HAS_SETREGID
2584         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2585 #else
2586 #ifdef HAS_SETRESGID
2587         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2588 #else
2589         if (PL_egid == PL_gid)                  /* special case $) = $( */
2590             (void)PerlProc_setgid(PL_egid);
2591         else {
2592             PL_egid = PerlProc_getegid();
2593             Perl_croak(aTHX_ "setegid() not implemented");
2594         }
2595 #endif
2596 #endif
2597 #endif
2598         PL_egid = PerlProc_getegid();
2599         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2600         break;
2601     case ':':
2602         PL_chopset = SvPV_force(sv,len);
2603         break;
2604 #ifndef MACOS_TRADITIONAL
2605     case '0':
2606         LOCK_DOLLARZERO_MUTEX;
2607 #ifdef HAS_SETPROCTITLE
2608         /* The BSDs don't show the argv[] in ps(1) output, they
2609          * show a string from the process struct and provide
2610          * the setproctitle() routine to manipulate that. */
2611         if (PL_origalen != 1) {
2612             s = SvPV_const(sv, len);
2613 #   if __FreeBSD_version > 410001
2614             /* The leading "-" removes the "perl: " prefix,
2615              * but not the "(perl) suffix from the ps(1)
2616              * output, because that's what ps(1) shows if the
2617              * argv[] is modified. */
2618             setproctitle("-%s", s);
2619 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2620             /* This doesn't really work if you assume that
2621              * $0 = 'foobar'; will wipe out 'perl' from the $0
2622              * because in ps(1) output the result will be like
2623              * sprintf("perl: %s (perl)", s)
2624              * I guess this is a security feature:
2625              * one (a user process) cannot get rid of the original name.
2626              * --jhi */
2627             setproctitle("%s", s);
2628 #   endif
2629         }
2630 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2631         if (PL_origalen != 1) {
2632              union pstun un;
2633              s = SvPV_const(sv, len);
2634              un.pst_command = (char *)s;
2635              pstat(PSTAT_SETCMD, un, len, 0, 0);
2636         }
2637 #else
2638         if (PL_origalen > 1) {
2639             /* PL_origalen is set in perl_parse(). */
2640             s = SvPV_force(sv,len);
2641             if (len >= (STRLEN)PL_origalen-1) {
2642                 /* Longer than original, will be truncated. We assume that
2643                  * PL_origalen bytes are available. */
2644                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2645             }
2646             else {
2647                 /* Shorter than original, will be padded. */
2648 #ifdef PERL_DARWIN
2649                 /* Special case for Mac OS X: see [perl #38868] */
2650                 const int pad = 0;
2651 #else
2652                 /* Is the space counterintuitive?  Yes.
2653                  * (You were expecting \0?)
2654                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2655                  * --jhi */
2656                 const int pad = ' ';
2657 #endif
2658                 Copy(s, PL_origargv[0], len, char);
2659                 PL_origargv[0][len] = 0;
2660                 memset(PL_origargv[0] + len + 1,
2661                        pad,  PL_origalen - len - 1);
2662             }
2663             PL_origargv[0][PL_origalen-1] = 0;
2664             for (i = 1; i < PL_origargc; i++)
2665                 PL_origargv[i] = 0;
2666         }
2667 #endif
2668         UNLOCK_DOLLARZERO_MUTEX;
2669         break;
2670 #endif
2671     }
2672     return 0;
2673 }
2674
2675 I32
2676 Perl_whichsig(pTHX_ const char *sig)
2677 {
2678     register char* const* sigv;
2679     PERL_UNUSED_CONTEXT;
2680
2681     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2682         if (strEQ(sig,*sigv))
2683             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2684 #ifdef SIGCLD
2685     if (strEQ(sig,"CHLD"))
2686         return SIGCLD;
2687 #endif
2688 #ifdef SIGCHLD
2689     if (strEQ(sig,"CLD"))
2690         return SIGCHLD;
2691 #endif
2692     return -1;
2693 }
2694
2695 Signal_t
2696 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2697 Perl_sighandler(int sig, ...)
2698 #else
2699 Perl_sighandler(int sig)
2700 #endif
2701 {
2702 #ifdef PERL_GET_SIG_CONTEXT
2703     dTHXa(PERL_GET_SIG_CONTEXT);
2704 #else
2705     dTHX;
2706 #endif
2707     dSP;
2708     GV *gv = NULL;
2709     SV *sv = NULL;
2710     SV * const tSv = PL_Sv;
2711     CV *cv = NULL;
2712     OP *myop = PL_op;
2713     U32 flags = 0;
2714     XPV * const tXpv = PL_Xpv;
2715
2716     if (PL_savestack_ix + 15 <= PL_savestack_max)
2717         flags |= 1;
2718     if (PL_markstack_ptr < PL_markstack_max - 2)
2719         flags |= 4;
2720     if (PL_scopestack_ix < PL_scopestack_max - 3)
2721         flags |= 16;
2722
2723     if (!PL_psig_ptr[sig]) {
2724                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2725                                  PL_sig_name[sig]);
2726                 exit(sig);
2727         }
2728
2729     /* Max number of items pushed there is 3*n or 4. We cannot fix
2730        infinity, so we fix 4 (in fact 5): */
2731     if (flags & 1) {
2732         PL_savestack_ix += 5;           /* Protect save in progress. */
2733         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2734     }
2735     if (flags & 4)
2736         PL_markstack_ptr++;             /* Protect mark. */
2737     if (flags & 16)
2738         PL_scopestack_ix += 1;
2739     /* sv_2cv is too complicated, try a simpler variant first: */
2740     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2741         || SvTYPE(cv) != SVt_PVCV) {
2742         HV *st;
2743         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2744     }
2745
2746     if (!cv || !CvROOT(cv)) {
2747         if (ckWARN(WARN_SIGNAL))
2748             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2749                 PL_sig_name[sig], (gv ? GvENAME(gv)
2750                                 : ((cv && CvGV(cv))
2751                                    ? GvENAME(CvGV(cv))
2752                                    : "__ANON__")));
2753         goto cleanup;
2754     }
2755
2756     if(PL_psig_name[sig]) {
2757         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2758         flags |= 64;
2759 #if !defined(PERL_IMPLICIT_CONTEXT)
2760         PL_sig_sv = sv;
2761 #endif
2762     } else {
2763         sv = sv_newmortal();
2764         sv_setpv(sv,PL_sig_name[sig]);
2765     }
2766
2767     PUSHSTACKi(PERLSI_SIGNAL);
2768     PUSHMARK(SP);
2769     PUSHs(sv);
2770 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2771     {
2772          struct sigaction oact;
2773
2774          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2775               siginfo_t *sip;
2776               va_list args;
2777
2778               va_start(args, sig);
2779               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2780               if (sip) {
2781                    HV *sih = newHV();
2782                    SV *rv  = newRV_noinc((SV*)sih);
2783                    /* The siginfo fields signo, code, errno, pid, uid,
2784                     * addr, status, and band are defined by POSIX/SUSv3. */
2785                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2786                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2787 #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. */
2788                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2789                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2790                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2791                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2792                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2793                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2794 #endif
2795                    EXTEND(SP, 2);
2796                    PUSHs((SV*)rv);
2797                    PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2798               }
2799
2800               va_end(args);
2801          }
2802     }
2803 #endif
2804     PUTBACK;
2805
2806     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2807
2808     POPSTACK;
2809     if (SvTRUE(ERRSV)) {
2810 #ifndef PERL_MICRO
2811 #ifdef HAS_SIGPROCMASK
2812         /* Handler "died", for example to get out of a restart-able read().
2813          * Before we re-do that on its behalf re-enable the signal which was
2814          * blocked by the system when we entered.
2815          */
2816         sigset_t set;
2817         sigemptyset(&set);
2818         sigaddset(&set,sig);
2819         sigprocmask(SIG_UNBLOCK, &set, NULL);
2820 #else
2821         /* Not clear if this will work */
2822         (void)rsignal(sig, SIG_IGN);
2823         (void)rsignal(sig, PL_csighandlerp);
2824 #endif
2825 #endif /* !PERL_MICRO */
2826         Perl_die(aTHX_ NULL);
2827     }
2828 cleanup:
2829     if (flags & 1)
2830         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2831     if (flags & 4)
2832         PL_markstack_ptr--;
2833     if (flags & 16)
2834         PL_scopestack_ix -= 1;
2835     if (flags & 64)
2836         SvREFCNT_dec(sv);
2837     PL_op = myop;                       /* Apparently not needed... */
2838
2839     PL_Sv = tSv;                        /* Restore global temporaries. */
2840     PL_Xpv = tXpv;
2841     return;
2842 }
2843
2844
2845 static void
2846 S_restore_magic(pTHX_ const void *p)
2847 {
2848     dVAR;
2849     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2850     SV* const sv = mgs->mgs_sv;
2851
2852     if (!sv)
2853         return;
2854
2855     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2856     {
2857 #ifdef PERL_OLD_COPY_ON_WRITE
2858         /* While magic was saved (and off) sv_setsv may well have seen
2859            this SV as a prime candidate for COW.  */
2860         if (SvIsCOW(sv))
2861             sv_force_normal_flags(sv, 0);
2862 #endif
2863
2864         if (mgs->mgs_flags)
2865             SvFLAGS(sv) |= mgs->mgs_flags;
2866         else
2867             mg_magical(sv);
2868         if (SvGMAGICAL(sv)) {
2869             /* downgrade public flags to private,
2870                and discard any other private flags */
2871
2872             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2873             if (pubflags) {
2874                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2875                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2876             }
2877         }
2878     }
2879
2880     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2881
2882     /* If we're still on top of the stack, pop us off.  (That condition
2883      * will be satisfied if restore_magic was called explicitly, but *not*
2884      * if it's being called via leave_scope.)
2885      * The reason for doing this is that otherwise, things like sv_2cv()
2886      * may leave alloc gunk on the savestack, and some code
2887      * (e.g. sighandler) doesn't expect that...
2888      */
2889     if (PL_savestack_ix == mgs->mgs_ss_ix)
2890     {
2891         I32 popval = SSPOPINT;
2892         assert(popval == SAVEt_DESTRUCTOR_X);
2893         PL_savestack_ix -= 2;
2894         popval = SSPOPINT;
2895         assert(popval == SAVEt_ALLOC);
2896         popval = SSPOPINT;
2897         PL_savestack_ix -= popval;
2898     }
2899
2900 }
2901
2902 static void
2903 S_unwind_handler_stack(pTHX_ const void *p)
2904 {
2905     dVAR;
2906     const U32 flags = *(const U32*)p;
2907
2908     if (flags & 1)
2909         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2910 #if !defined(PERL_IMPLICIT_CONTEXT)
2911     if (flags & 64)
2912         SvREFCNT_dec(PL_sig_sv);
2913 #endif
2914 }
2915
2916 /*
2917 =for apidoc magic_sethint
2918
2919 Triggered by a store to %^H, records the key/value pair to
2920 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
2921 anything that would need a deep copy.  Maybe we should warn if we find a
2922 reference.
2923
2924 =cut
2925 */
2926 int
2927 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2928 {
2929     dVAR;
2930     assert(mg->mg_len == HEf_SVKEY);
2931
2932     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
2933        an alternative leaf in there, with PL_compiling.cop_hints being used if
2934        it's NULL. If needed for threads, the alternative could lock a mutex,
2935        or take other more complex action.  */
2936
2937     /* Something changed in %^H, so it will need to be restored on scope exit.
2938        Doing this here saves a lot of doing it manually in perl code (and
2939        forgetting to do it, and consequent subtle errors.  */
2940     PL_hints |= HINT_LOCALIZE_HH;
2941     PL_compiling.cop_hints_hash
2942         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2943                                  (SV *)mg->mg_ptr, sv);
2944     return 0;
2945 }
2946
2947 /*
2948 =for apidoc magic_sethint
2949
2950 Triggered by a delete from %^H, records the key to
2951 C<PL_compiling.cop_hints_hash>.
2952
2953 =cut
2954 */
2955 int
2956 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2957 {
2958     dVAR;
2959     PERL_UNUSED_ARG(sv);
2960
2961     assert(mg->mg_len == HEf_SVKEY);
2962
2963     PERL_UNUSED_ARG(sv);
2964
2965     PL_hints |= HINT_LOCALIZE_HH;
2966     PL_compiling.cop_hints_hash
2967         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2968                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
2969     return 0;
2970 }
2971
2972 /*
2973  * Local variables:
2974  * c-indentation-style: bsd
2975  * c-basic-offset: 4
2976  * indent-tabs-mode: t
2977  * End:
2978  *
2979  * ex: set ts=8 sts=4 sw=4 noet:
2980  */