mg.c

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