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