mg.c

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