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