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