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