mg.c

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