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     while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
 647         --len; \
 648     SvCUR_set(sv, len); \
 649 } STMT_END
 650
 651 int
 652 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 653 {
 654     dVAR;
 655     register I32 paren;
 656     register char *s = NULL;
 657     register I32 i;
 658     register REGEXP *rx;
 659     const char * const remaining = mg->mg_ptr + 1;
 660     const char nextchar = *remaining;
 661
 662     switch (*mg->mg_ptr) {
 663     case '\001':                /* ^A */
 664         sv_setsv(sv, PL_bodytarget);
 665         break;
 666     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 667         if (nextchar == '\0') {
 668             sv_setiv(sv, (IV)PL_minus_c);
 669         }
 670         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 671             sv_setiv(sv, (IV)STATUS_NATIVE);
 672         }
 673         break;
 674
 675     case '\004':                /* ^D */
 676         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 677         break;
 678     case '\005':  /* ^E */
 679          if (nextchar == '\0') {
 680 #ifdef MACOS_TRADITIONAL
 681              {
 682                   char msg[256];
 683
 684                   sv_setnv(sv,(double)gMacPerl_OSErr);
 685                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 686              }
 687 #else
 688 #ifdef VMS
 689              {
 690 #                 include <descrip.h>
 691 #                 include <starlet.h>
 692                   char msg[255];
 693                   $DESCRIPTOR(msgdsc,msg);
 694                   sv_setnv(sv,(NV) vaxc$errno);
 695                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 696                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 697                   else
 698                        sv_setpvn(sv,"",0);
 699              }
 700 #else
 701 #ifdef OS2
 702              if (!(_emx_env & 0x200)) { /* Under DOS */
 703                   sv_setnv(sv, (NV)errno);
 704                   sv_setpv(sv, errno ? Strerror(errno) : "");
 705              } else {
 706                   if (errno != errno_isOS2) {
 707                        const int tmp = _syserrno();
 708                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 709                             Perl_rc = tmp;
 710                   }
 711                   sv_setnv(sv, (NV)Perl_rc);
 712                   sv_setpv(sv, os2error(Perl_rc));
 713              }
 714 #else
 715 #ifdef WIN32
 716              {
 717                   DWORD dwErr = GetLastError();
 718                   sv_setnv(sv, (NV)dwErr);
 719                   if (dwErr) {
 720                        PerlProc_GetOSError(sv, dwErr);
 721                   }
 722                   else
 723                        sv_setpvn(sv, "", 0);
 724                   SetLastError(dwErr);
 725              }
 726 #else
 727              {
 728                  const int saveerrno = errno;
 729                  sv_setnv(sv, (NV)errno);
 730                  sv_setpv(sv, errno ? Strerror(errno) : "");
 731                  errno = saveerrno;
 732              }
 733 #endif
 734 #endif
 735 #endif
 736 #endif
 737              SvRTRIM(sv);
 738              SvNOK_on(sv);      /* what a wonderful hack! */
 739          }
 740          else if (strEQ(remaining, "NCODING"))
 741               sv_setsv(sv, PL_encoding);
 742          break;
 743     case '\006':                /* ^F */
 744         sv_setiv(sv, (IV)PL_maxsysfd);
 745         break;
 746     case '\010':                /* ^H */
 747         sv_setiv(sv, (IV)PL_hints);
 748         break;
 749     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 750         if (PL_inplace)
 751             sv_setpv(sv, PL_inplace);
 752         else
 753             sv_setsv(sv, &PL_sv_undef);
 754         break;
 755     case '\017':                /* ^O & ^OPEN */
 756         if (nextchar == '\0') {
 757             sv_setpv(sv, PL_osname);
 758             SvTAINTED_off(sv);
 759         }
 760         else if (strEQ(remaining, "PEN")) {
 761             if (!PL_compiling.cop_io)
 762                 sv_setsv(sv, &PL_sv_undef);
 763             else {
 764                 sv_setsv(sv, PL_compiling.cop_io);
 765             }
 766         }
 767         break;
 768     case '\020':                /* ^P */
 769         sv_setiv(sv, (IV)PL_perldb);
 770         break;
 771     case '\023':                /* ^S */
 772         if (nextchar == '\0') {
 773             if (PL_lex_state != LEX_NOTPARSING)
 774                 SvOK_off(sv);
 775             else if (PL_in_eval)
 776                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 777             else
 778                 sv_setiv(sv, 0);
 779         }
 780         break;
 781     case '\024':                /* ^T */
 782         if (nextchar == '\0') {
 783 #ifdef BIG_TIME
 784             sv_setnv(sv, PL_basetime);
 785 #else
 786             sv_setiv(sv, (IV)PL_basetime);
 787 #endif
 788         }
 789         else if (strEQ(remaining, "AINT"))
 790             sv_setiv(sv, PL_tainting
 791                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 792                     : 0);
 793         break;
 794     case '\025':                /* $^UNICODE, $^UTF8LOCALE */
 795         if (strEQ(remaining, "NICODE"))
 796             sv_setuv(sv, (UV) PL_unicode);
 797         else if (strEQ(remaining, "TF8LOCALE"))
 798             sv_setuv(sv, (UV) PL_utf8locale);
 799         break;
 800     case '\027':                /* ^W  & $^WARNING_BITS */
 801         if (nextchar == '\0')
 802             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 803         else if (strEQ(remaining, "ARNING_BITS")) {
 804             if (PL_compiling.cop_warnings == pWARN_NONE) {
 805                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 806             }
 807             else if (PL_compiling.cop_warnings == pWARN_STD) {
 808                 sv_setpvn(
 809                     sv,
 810                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 811                     WARNsize
 812                 );
 813             }
 814             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 815                 /* Get the bit mask for $warnings::Bits{all}, because
 816                  * it could have been extended by warnings::register */
 817                 SV **bits_all;
 818                 HV * const bits=get_hv("warnings::Bits", FALSE);
 819                 if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
 820                     sv_setsv(sv, *bits_all);
 821                 }
 822                 else {
 823                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 824                 }
 825             }
 826             else {
 827                 sv_setsv(sv, PL_compiling.cop_warnings);
 828             }
 829             SvPOK_only(sv);
 830         }
 831         break;
 832     case '1': case '2': case '3': case '4':
 833     case '5': case '6': case '7': case '8': case '9': case '&':
 834         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 835             I32 s1, t1;
 836
 837             /*
 838              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 839              * XXX Does the new way break anything?
 840              */
 841             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 842           getparen:
 843             if (paren <= (I32)rx->nparens &&
 844                 (s1 = rx->startp[paren]) != -1 &&
 845                 (t1 = rx->endp[paren]) != -1)
 846             {
 847                 i = t1 - s1;
 848                 s = rx->subbeg + s1;
 849                 if (!rx->subbeg)
 850                     break;
 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 #ifdef HAS_GETGROUPS
1006         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
1007 #endif
1008         goto add_groups;
1009     case ')':
1010         sv_setiv(sv, (IV)PL_egid);
1011 #ifdef HAS_GETGROUPS
1012         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
1013 #endif
1014       add_groups:
1015 #ifdef HAS_GETGROUPS
1016         {
1017             Groups_t *gary = NULL;
1018             I32 num_groups = getgroups(0, gary);
1019             Newx(gary, num_groups, Groups_t);
1020             num_groups = getgroups(num_groups, gary);
1021             while (--num_groups >= 0)
1022                 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
1023                                gary[num_groups]);
1024             Safefree(gary);
1025         }
1026 #endif
1027         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1028         break;
1029 #ifndef MACOS_TRADITIONAL
1030     case '0':
1031         break;
1032 #endif
1033     }
1034     return 0;
1035 }
1036
1037 int
1038 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1039 {
1040     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1041
1042     if (uf && uf->uf_val)
1043         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1044     return 0;
1045 }
1046
1047 int
1048 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1049 {
1050     dVAR;
1051     STRLEN len, klen;
1052     const char *s = SvPV_const(sv,len);
1053     const char * const ptr = MgPV_const(mg,klen);
1054     my_setenv(ptr, s);
1055
1056 #ifdef DYNAMIC_ENV_FETCH
1057      /* We just undefd an environment var.  Is a replacement */
1058      /* waiting in the wings? */
1059     if (!len) {
1060         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1061         if (valp)
1062             s = SvPV_const(*valp, len);
1063     }
1064 #endif
1065
1066 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1067                             /* And you'll never guess what the dog had */
1068                             /*   in its mouth... */
1069     if (PL_tainting) {
1070         MgTAINTEDDIR_off(mg);
1071 #ifdef VMS
1072         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1073             char pathbuf[256], eltbuf[256], *cp, *elt;
1074             Stat_t sbuf;
1075             int i = 0, j = 0;
1076
1077             strncpy(eltbuf, s, 255);
1078             eltbuf[255] = 0;
1079             elt = eltbuf;
1080             do {          /* DCL$PATH may be a search list */
1081                 while (1) {   /* as may dev portion of any element */
1082                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1083                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1084                              cando_by_name(S_IWUSR,0,elt) ) {
1085                             MgTAINTEDDIR_on(mg);
1086                             return 0;
1087                         }
1088                     }
1089                     if ((cp = strchr(elt, ':')) != Nullch)
1090                         *cp = '\0';
1091                     if (my_trnlnm(elt, eltbuf, j++))
1092                         elt = eltbuf;
1093                     else
1094                         break;
1095                 }
1096                 j = 0;
1097             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1098         }
1099 #endif /* VMS */
1100         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1101             const char * const strend = s + len;
1102
1103             while (s < strend) {
1104                 char tmpbuf[256];
1105                 Stat_t st;
1106                 I32 i;
1107                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1108                              s, strend, ':', &i);
1109                 s++;
1110                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
1111                       || *tmpbuf != '/'
1112                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1113                     MgTAINTEDDIR_on(mg);
1114                     return 0;
1115                 }
1116             }
1117         }
1118     }
1119 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1120
1121     return 0;
1122 }
1123
1124 int
1125 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1126 {
1127     PERL_UNUSED_ARG(sv);
1128     my_setenv(MgPV_nolen_const(mg),Nullch);
1129     return 0;
1130 }
1131
1132 int
1133 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1134 {
1135     dVAR;
1136     PERL_UNUSED_ARG(mg);
1137 #if defined(VMS)
1138     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1139 #else
1140     if (PL_localizing) {
1141         HE* entry;
1142         my_clearenv();
1143         hv_iterinit((HV*)sv);
1144         while ((entry = hv_iternext((HV*)sv))) {
1145             I32 keylen;
1146             my_setenv(hv_iterkey(entry, &keylen),
1147                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1148         }
1149     }
1150 #endif
1151     return 0;
1152 }
1153
1154 int
1155 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1156 {
1157     dVAR;
1158     PERL_UNUSED_ARG(sv);
1159     PERL_UNUSED_ARG(mg);
1160 #if defined(VMS)
1161     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1162 #else
1163     my_clearenv();
1164 #endif
1165     return 0;
1166 }
1167
1168 #ifndef PERL_MICRO
1169 #ifdef HAS_SIGPROCMASK
1170 static void
1171 restore_sigmask(pTHX_ SV *save_sv)
1172 {
1173     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1174     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1175 }
1176 #endif
1177 int
1178 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1179 {
1180     dVAR;
1181     /* Are we fetching a signal entry? */
1182     const I32 i = whichsig(MgPV_nolen_const(mg));
1183     if (i > 0) {
1184         if(PL_psig_ptr[i])
1185             sv_setsv(sv,PL_psig_ptr[i]);
1186         else {
1187             Sighandler_t sigstate;
1188             sigstate = rsignal_state(i);
1189 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1190             if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
1191 #endif
1192 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1193             if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
1194 #endif
1195             /* cache state so we don't fetch it again */
1196             if(sigstate == (Sighandler_t) SIG_IGN)
1197                 sv_setpv(sv,"IGNORE");
1198             else
1199                 sv_setsv(sv,&PL_sv_undef);
1200             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1201             SvTEMP_off(sv);
1202         }
1203     }
1204     return 0;
1205 }
1206 int
1207 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1208 {
1209     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1210      * refactoring might be in order.
1211      */
1212     dVAR;
1213     register const char * const s = MgPV_nolen_const(mg);
1214     PERL_UNUSED_ARG(sv);
1215     if (*s == '_') {
1216         SV** svp = NULL;
1217         if (strEQ(s,"__DIE__"))
1218             svp = &PL_diehook;
1219         else if (strEQ(s,"__WARN__"))
1220             svp = &PL_warnhook;
1221         else
1222             Perl_croak(aTHX_ "No such hook: %s", s);
1223         if (svp && *svp) {
1224             SV * const to_dec = *svp;
1225             *svp = NULL;
1226             SvREFCNT_dec(to_dec);
1227         }
1228     }
1229     else {
1230         /* Are we clearing a signal entry? */
1231         const I32 i = whichsig(s);
1232         if (i > 0) {
1233 #ifdef HAS_SIGPROCMASK
1234             sigset_t set, save;
1235             SV* save_sv;
1236             /* Avoid having the signal arrive at a bad time, if possible. */
1237             sigemptyset(&set);
1238             sigaddset(&set,i);
1239             sigprocmask(SIG_BLOCK, &set, &save);
1240             ENTER;
1241             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1242             SAVEFREESV(save_sv);
1243             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1244 #endif
1245             PERL_ASYNC_CHECK();
1246 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1247             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1248 #endif
1249 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1250             PL_sig_defaulting[i] = 1;
1251             (void)rsignal(i, PL_csighandlerp);
1252 #else
1253             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1254 #endif
1255             if(PL_psig_name[i]) {
1256                 SvREFCNT_dec(PL_psig_name[i]);
1257                 PL_psig_name[i]=0;
1258             }
1259             if(PL_psig_ptr[i]) {
1260                 SV *to_dec=PL_psig_ptr[i];
1261                 PL_psig_ptr[i]=0;
1262                 LEAVE;
1263                 SvREFCNT_dec(to_dec);
1264             }
1265             else
1266                 LEAVE;
1267         }
1268     }
1269     return 0;
1270 }
1271
1272 static void
1273 S_raise_signal(pTHX_ int sig)
1274 {
1275     dVAR;
1276     /* Set a flag to say this signal is pending */
1277     PL_psig_pend[sig]++;
1278     /* And one to say _a_ signal is pending */
1279     PL_sig_pending = 1;
1280 }
1281
1282 Signal_t
1283 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1284 Perl_csighandler(int sig, ...)
1285 #else
1286 Perl_csighandler(int sig)
1287 #endif
1288 {
1289 #ifdef PERL_GET_SIG_CONTEXT
1290     dTHXa(PERL_GET_SIG_CONTEXT);
1291 #else
1292     dTHX;
1293 #endif
1294 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1295     (void) rsignal(sig, PL_csighandlerp);
1296     if (PL_sig_ignoring[sig]) return;
1297 #endif
1298 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1299     if (PL_sig_defaulting[sig])
1300 #ifdef KILL_BY_SIGPRC
1301             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1302 #else
1303             exit(1);
1304 #endif
1305 #endif
1306    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1307         /* Call the perl level handler now--
1308          * with risk we may be in malloc() etc. */
1309         (*PL_sighandlerp)(sig);
1310    else
1311         S_raise_signal(aTHX_ sig);
1312 }
1313
1314 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1315 void
1316 Perl_csighandler_init(void)
1317 {
1318     int sig;
1319     if (PL_sig_handlers_initted) return;
1320
1321     for (sig = 1; sig < SIG_SIZE; sig++) {
1322 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1323         dTHX;
1324         PL_sig_defaulting[sig] = 1;
1325         (void) rsignal(sig, PL_csighandlerp);
1326 #endif
1327 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1328         PL_sig_ignoring[sig] = 0;
1329 #endif
1330     }
1331     PL_sig_handlers_initted = 1;
1332 }
1333 #endif
1334
1335 void
1336 Perl_despatch_signals(pTHX)
1337 {
1338     dVAR;
1339     int sig;
1340     PL_sig_pending = 0;
1341     for (sig = 1; sig < SIG_SIZE; sig++) {
1342         if (PL_psig_pend[sig]) {
1343             PERL_BLOCKSIG_ADD(set, sig);
1344             PL_psig_pend[sig] = 0;
1345             PERL_BLOCKSIG_BLOCK(set);
1346             (*PL_sighandlerp)(sig);
1347             PERL_BLOCKSIG_UNBLOCK(set);
1348         }
1349     }
1350 }
1351
1352 int
1353 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1354 {
1355     dVAR;
1356     I32 i;
1357     SV** svp = NULL;
1358     /* Need to be careful with SvREFCNT_dec(), because that can have side
1359      * effects (due to closures). We must make sure that the new disposition
1360      * is in place before it is called.
1361      */
1362     SV* to_dec = NULL;
1363     STRLEN len;
1364 #ifdef HAS_SIGPROCMASK
1365     sigset_t set, save;
1366     SV* save_sv;
1367 #endif
1368
1369     register const char *s = MgPV_const(mg,len);
1370     if (*s == '_') {
1371         if (strEQ(s,"__DIE__"))
1372             svp = &PL_diehook;
1373         else if (strEQ(s,"__WARN__"))
1374             svp = &PL_warnhook;
1375         else
1376             Perl_croak(aTHX_ "No such hook: %s", s);
1377         i = 0;
1378         if (*svp) {
1379             to_dec = *svp;
1380             *svp = NULL;
1381         }
1382     }
1383     else {
1384         i = whichsig(s);        /* ...no, a brick */
1385         if (i <= 0) {
1386             if (ckWARN(WARN_SIGNAL))
1387                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1388             return 0;
1389         }
1390 #ifdef HAS_SIGPROCMASK
1391         /* Avoid having the signal arrive at a bad time, if possible. */
1392         sigemptyset(&set);
1393         sigaddset(&set,i);
1394         sigprocmask(SIG_BLOCK, &set, &save);
1395         ENTER;
1396         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1397         SAVEFREESV(save_sv);
1398         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1399 #endif
1400         PERL_ASYNC_CHECK();
1401 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1402         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1403 #endif
1404 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1405         PL_sig_ignoring[i] = 0;
1406 #endif
1407 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1408         PL_sig_defaulting[i] = 0;
1409 #endif
1410         SvREFCNT_dec(PL_psig_name[i]);
1411         to_dec = PL_psig_ptr[i];
1412         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1413         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1414         PL_psig_name[i] = newSVpvn(s, len);
1415         SvREADONLY_on(PL_psig_name[i]);
1416     }
1417     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1418         if (i) {
1419             (void)rsignal(i, PL_csighandlerp);
1420 #ifdef HAS_SIGPROCMASK
1421             LEAVE;
1422 #endif
1423         }
1424         else
1425             *svp = SvREFCNT_inc(sv);
1426         if(to_dec)
1427             SvREFCNT_dec(to_dec);
1428         return 0;
1429     }
1430     s = SvPV_force(sv,len);
1431     if (strEQ(s,"IGNORE")) {
1432         if (i) {
1433 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1434             PL_sig_ignoring[i] = 1;
1435             (void)rsignal(i, PL_csighandlerp);
1436 #else
1437             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1438 #endif
1439         }
1440     }
1441     else if (strEQ(s,"DEFAULT") || !*s) {
1442         if (i)
1443 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1444           {
1445             PL_sig_defaulting[i] = 1;
1446             (void)rsignal(i, PL_csighandlerp);
1447           }
1448 #else
1449             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1450 #endif
1451     }
1452     else {
1453         /*
1454          * We should warn if HINT_STRICT_REFS, but without
1455          * access to a known hint bit in a known OP, we can't
1456          * tell whether HINT_STRICT_REFS is in force or not.
1457          */
1458         if (!strchr(s,':') && !strchr(s,'\''))
1459             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1460         if (i)
1461             (void)rsignal(i, PL_csighandlerp);
1462         else
1463             *svp = SvREFCNT_inc(sv);
1464     }
1465 #ifdef HAS_SIGPROCMASK
1466     if(i)
1467         LEAVE;
1468 #endif
1469     if(to_dec)
1470         SvREFCNT_dec(to_dec);
1471     return 0;
1472 }
1473 #endif /* !PERL_MICRO */
1474
1475 int
1476 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1477 {
1478     dVAR;
1479     PERL_UNUSED_ARG(sv);
1480     PERL_UNUSED_ARG(mg);
1481     PL_sub_generation++;
1482     return 0;
1483 }
1484
1485 int
1486 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1487 {
1488     dVAR;
1489     PERL_UNUSED_ARG(sv);
1490     PERL_UNUSED_ARG(mg);
1491     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1492     PL_amagic_generation++;
1493
1494     return 0;
1495 }
1496
1497 int
1498 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1499 {
1500     HV * const hv = (HV*)LvTARG(sv);
1501     I32 i = 0;
1502     PERL_UNUSED_ARG(mg);
1503
1504     if (hv) {
1505          (void) hv_iterinit(hv);
1506          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1507              i = HvKEYS(hv);
1508          else {
1509              while (hv_iternext(hv))
1510                  i++;
1511          }
1512     }
1513
1514     sv_setiv(sv, (IV)i);
1515     return 0;
1516 }
1517
1518 int
1519 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1520 {
1521     PERL_UNUSED_ARG(mg);
1522     if (LvTARG(sv)) {
1523         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1524     }
1525     return 0;
1526 }
1527
1528 /* caller is responsible for stack switching/cleanup */
1529 STATIC int
1530 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1531 {
1532     dVAR;
1533     dSP;
1534
1535     PUSHMARK(SP);
1536     EXTEND(SP, n);
1537     PUSHs(SvTIED_obj(sv, mg));
1538     if (n > 1) {
1539         if (mg->mg_ptr) {
1540             if (mg->mg_len >= 0)
1541                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1542             else if (mg->mg_len == HEf_SVKEY)
1543                 PUSHs((SV*)mg->mg_ptr);
1544         }
1545         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1546             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1547         }
1548     }
1549     if (n > 2) {
1550         PUSHs(val);
1551     }
1552     PUTBACK;
1553
1554     return call_method(meth, flags);
1555 }
1556
1557 STATIC int
1558 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1559 {
1560     dVAR; dSP;
1561
1562     ENTER;
1563     SAVETMPS;
1564     PUSHSTACKi(PERLSI_MAGIC);
1565
1566     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1567         sv_setsv(sv, *PL_stack_sp--);
1568     }
1569
1570     POPSTACK;
1571     FREETMPS;
1572     LEAVE;
1573     return 0;
1574 }
1575
1576 int
1577 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1578 {
1579     if (mg->mg_ptr)
1580         mg->mg_flags |= MGf_GSKIP;
1581     magic_methpack(sv,mg,"FETCH");
1582     return 0;
1583 }
1584
1585 int
1586 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1587 {
1588     dVAR; dSP;
1589     ENTER;
1590     PUSHSTACKi(PERLSI_MAGIC);
1591     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1592     POPSTACK;
1593     LEAVE;
1594     return 0;
1595 }
1596
1597 int
1598 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1599 {
1600     return magic_methpack(sv,mg,"DELETE");
1601 }
1602
1603
1604 U32
1605 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1606 {
1607     dVAR; dSP;
1608     U32 retval = 0;
1609
1610     ENTER;
1611     SAVETMPS;
1612     PUSHSTACKi(PERLSI_MAGIC);
1613     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1614         sv = *PL_stack_sp--;
1615         retval = (U32) SvIV(sv)-1;
1616     }
1617     POPSTACK;
1618     FREETMPS;
1619     LEAVE;
1620     return retval;
1621 }
1622
1623 int
1624 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1625 {
1626     dVAR; dSP;
1627
1628     ENTER;
1629     PUSHSTACKi(PERLSI_MAGIC);
1630     PUSHMARK(SP);
1631     XPUSHs(SvTIED_obj(sv, mg));
1632     PUTBACK;
1633     call_method("CLEAR", G_SCALAR|G_DISCARD);
1634     POPSTACK;
1635     LEAVE;
1636
1637     return 0;
1638 }
1639
1640 int
1641 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1642 {
1643     dVAR; dSP;
1644     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1645
1646     ENTER;
1647     SAVETMPS;
1648     PUSHSTACKi(PERLSI_MAGIC);
1649     PUSHMARK(SP);
1650     EXTEND(SP, 2);
1651     PUSHs(SvTIED_obj(sv, mg));
1652     if (SvOK(key))
1653         PUSHs(key);
1654     PUTBACK;
1655
1656     if (call_method(meth, G_SCALAR))
1657         sv_setsv(key, *PL_stack_sp--);
1658
1659     POPSTACK;
1660     FREETMPS;
1661     LEAVE;
1662     return 0;
1663 }
1664
1665 int
1666 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1667 {
1668     return magic_methpack(sv,mg,"EXISTS");
1669 }
1670
1671 SV *
1672 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1673 {
1674     dVAR; dSP;
1675     SV *retval = &PL_sv_undef;
1676     SV * const tied = SvTIED_obj((SV*)hv, mg);
1677     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1678
1679     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1680         SV *key;
1681         if (HvEITER_get(hv))
1682             /* we are in an iteration so the hash cannot be empty */
1683             return &PL_sv_yes;
1684         /* no xhv_eiter so now use FIRSTKEY */
1685         key = sv_newmortal();
1686         magic_nextpack((SV*)hv, mg, key);
1687         HvEITER_set(hv, NULL);     /* need to reset iterator */
1688         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1689     }
1690
1691     /* there is a SCALAR method that we can call */
1692     ENTER;
1693     PUSHSTACKi(PERLSI_MAGIC);
1694     PUSHMARK(SP);
1695     EXTEND(SP, 1);
1696     PUSHs(tied);
1697     PUTBACK;
1698
1699     if (call_method("SCALAR", G_SCALAR))
1700         retval = *PL_stack_sp--;
1701     POPSTACK;
1702     LEAVE;
1703     return retval;
1704 }
1705
1706 int
1707 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1708 {
1709     dVAR;
1710     GV * const gv = PL_DBline;
1711     const I32 i = SvTRUE(sv);
1712     SV ** const svp = av_fetch(GvAV(gv),
1713                      atoi(MgPV_nolen_const(mg)), FALSE);
1714     if (svp && SvIOKp(*svp)) {
1715         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1716         if (o) {
1717             /* set or clear breakpoint in the relevant control op */
1718             if (i)
1719                 o->op_flags |= OPf_SPECIAL;
1720             else
1721                 o->op_flags &= ~OPf_SPECIAL;
1722         }
1723     }
1724     return 0;
1725 }
1726
1727 int
1728 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1729 {
1730     dVAR;
1731     const AV * const obj = (AV*)mg->mg_obj;
1732     if (obj) {
1733         sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
1734     } else {
1735         SvOK_off(sv);
1736     }
1737     return 0;
1738 }
1739
1740 int
1741 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1742 {
1743     dVAR;
1744     AV * const obj = (AV*)mg->mg_obj;
1745     if (obj) {
1746         av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
1747     } else {
1748         if (ckWARN(WARN_MISC))
1749             Perl_warner(aTHX_ packWARN(WARN_MISC),
1750                         "Attempt to set length of freed array");
1751     }
1752     return 0;
1753 }
1754
1755 int
1756 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1757 {
1758     dVAR;
1759     PERL_UNUSED_ARG(sv);
1760     /* during global destruction, mg_obj may already have been freed */
1761     if (PL_in_clean_all)
1762         return 0;
1763
1764     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1765
1766     if (mg) {
1767         /* arylen scalar holds a pointer back to the array, but doesn't own a
1768            reference. Hence the we (the array) are about to go away with it
1769            still pointing at us. Clear its pointer, else it would be pointing
1770            at free memory. See the comment in sv_magic about reference loops,
1771            and why it can't own a reference to us.  */
1772         mg->mg_obj = 0;
1773     }
1774     return 0;
1775 }
1776
1777 int
1778 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1779 {
1780     dVAR;
1781     SV* const lsv = LvTARG(sv);
1782
1783     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1784         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1785         if (mg && mg->mg_len >= 0) {
1786             I32 i = mg->mg_len;
1787             if (DO_UTF8(lsv))
1788                 sv_pos_b2u(lsv, &i);
1789             sv_setiv(sv, i + PL_curcop->cop_arybase);
1790             return 0;
1791         }
1792     }
1793     SvOK_off(sv);
1794     return 0;
1795 }
1796
1797 int
1798 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1799 {
1800     dVAR;
1801     SV* const lsv = LvTARG(sv);
1802     SSize_t pos;
1803     STRLEN len;
1804     STRLEN ulen = 0;
1805
1806     mg = 0;
1807
1808     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1809         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1810     if (!mg) {
1811         if (!SvOK(sv))
1812             return 0;
1813         sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
1814         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1815     }
1816     else if (!SvOK(sv)) {
1817         mg->mg_len = -1;
1818         return 0;
1819     }
1820     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1821
1822     pos = SvIV(sv) - PL_curcop->cop_arybase;
1823
1824     if (DO_UTF8(lsv)) {
1825         ulen = sv_len_utf8(lsv);
1826         if (ulen)
1827             len = ulen;
1828     }
1829
1830     if (pos < 0) {
1831         pos += len;
1832         if (pos < 0)
1833             pos = 0;
1834     }
1835     else if (pos > (SSize_t)len)
1836         pos = len;
1837
1838     if (ulen) {
1839         I32 p = pos;
1840         sv_pos_u2b(lsv, &p, 0);
1841         pos = p;
1842     }
1843
1844     mg->mg_len = pos;
1845     mg->mg_flags &= ~MGf_MINMATCH;
1846
1847     return 0;
1848 }
1849
1850 int
1851 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1852 {
1853     PERL_UNUSED_ARG(mg);
1854     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1855         SvFAKE_off(sv);
1856         gv_efullname3(sv,((GV*)sv), "*");
1857         SvFAKE_on(sv);
1858     }
1859     else
1860         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1861     return 0;
1862 }
1863
1864 int
1865 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1866 {
1867     GV* gv;
1868     PERL_UNUSED_ARG(mg);
1869
1870     if (!SvOK(sv))
1871         return 0;
1872     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1873     if (sv == (SV*)gv)
1874         return 0;
1875     if (GvGP(sv))
1876         gp_free((GV*)sv);
1877     GvGP(sv) = gp_ref(GvGP(gv));
1878     return 0;
1879 }
1880
1881 int
1882 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1883 {
1884     STRLEN len;
1885     SV * const lsv = LvTARG(sv);
1886     const char * const tmps = SvPV_const(lsv,len);
1887     I32 offs = LvTARGOFF(sv);
1888     I32 rem = LvTARGLEN(sv);
1889     PERL_UNUSED_ARG(mg);
1890
1891     if (SvUTF8(lsv))
1892         sv_pos_u2b(lsv, &offs, &rem);
1893     if (offs > (I32)len)
1894         offs = len;
1895     if (rem + offs > (I32)len)
1896         rem = len - offs;
1897     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1898     if (SvUTF8(lsv))
1899         SvUTF8_on(sv);
1900     return 0;
1901 }
1902
1903 int
1904 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1905 {
1906     dVAR;
1907     STRLEN len;
1908     const char *tmps = SvPV_const(sv, len);
1909     SV * const lsv = LvTARG(sv);
1910     I32 lvoff = LvTARGOFF(sv);
1911     I32 lvlen = LvTARGLEN(sv);
1912     PERL_UNUSED_ARG(mg);
1913
1914     if (DO_UTF8(sv)) {
1915         sv_utf8_upgrade(lsv);
1916         sv_pos_u2b(lsv, &lvoff, &lvlen);
1917         sv_insert(lsv, lvoff, lvlen, tmps, len);
1918         LvTARGLEN(sv) = sv_len_utf8(sv);
1919         SvUTF8_on(lsv);
1920     }
1921     else if (lsv && SvUTF8(lsv)) {
1922         sv_pos_u2b(lsv, &lvoff, &lvlen);
1923         LvTARGLEN(sv) = len;
1924         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1925         sv_insert(lsv, lvoff, lvlen, tmps, len);
1926         Safefree(tmps);
1927     }
1928     else {
1929         sv_insert(lsv, lvoff, lvlen, tmps, len);
1930         LvTARGLEN(sv) = len;
1931     }
1932
1933
1934     return 0;
1935 }
1936
1937 int
1938 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1939 {
1940     dVAR;
1941     PERL_UNUSED_ARG(sv);
1942     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1943     return 0;
1944 }
1945
1946 int
1947 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1948 {
1949     dVAR;
1950     PERL_UNUSED_ARG(sv);
1951     /* update taint status unless we're restoring at scope exit */
1952     if (PL_localizing != 2) {
1953         if (PL_tainted)
1954             mg->mg_len |= 1;
1955         else
1956             mg->mg_len &= ~1;
1957     }
1958     return 0;
1959 }
1960
1961 int
1962 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1963 {
1964     SV * const lsv = LvTARG(sv);
1965     PERL_UNUSED_ARG(mg);
1966
1967     if (!lsv) {
1968         SvOK_off(sv);
1969         return 0;
1970     }
1971
1972     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
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         /* PL_origalen is set in perl_parse(). */
2572         s = SvPV_force(sv,len);
2573         if (len >= (STRLEN)PL_origalen-1) {
2574             /* Longer than original, will be truncated. We assume that
2575              * PL_origalen bytes are available. */
2576             Copy(s, PL_origargv[0], PL_origalen-1, char);
2577         }
2578         else {
2579             /* Shorter than original, will be padded. */
2580             Copy(s, PL_origargv[0], len, char);
2581             PL_origargv[0][len] = 0;
2582             memset(PL_origargv[0] + len + 1,
2583                    /* Is the space counterintuitive?  Yes.
2584                     * (You were expecting \0?)
2585                     * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2586                     * --jhi */
2587                    (int)' ',
2588                    PL_origalen - len - 1);
2589         }
2590         PL_origargv[0][PL_origalen-1] = 0;
2591         for (i = 1; i < PL_origargc; i++)
2592             PL_origargv[i] = 0;
2593         UNLOCK_DOLLARZERO_MUTEX;
2594         break;
2595 #endif
2596     }
2597     return 0;
2598 }
2599
2600 I32
2601 Perl_whichsig(pTHX_ const char *sig)
2602 {
2603     register char* const* sigv;
2604
2605     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2606         if (strEQ(sig,*sigv))
2607             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2608 #ifdef SIGCLD
2609     if (strEQ(sig,"CHLD"))
2610         return SIGCLD;
2611 #endif
2612 #ifdef SIGCHLD
2613     if (strEQ(sig,"CLD"))
2614         return SIGCHLD;
2615 #endif
2616     return -1;
2617 }
2618
2619 Signal_t
2620 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2621 Perl_sighandler(int sig, ...)
2622 #else
2623 Perl_sighandler(int sig)
2624 #endif
2625 {
2626 #ifdef PERL_GET_SIG_CONTEXT
2627     dTHXa(PERL_GET_SIG_CONTEXT);
2628 #else
2629     dTHX;
2630 #endif
2631     dSP;
2632     GV *gv = Nullgv;
2633     SV *sv = Nullsv;
2634     SV * const tSv = PL_Sv;
2635     CV *cv = Nullcv;
2636     OP *myop = PL_op;
2637     U32 flags = 0;
2638     XPV * const tXpv = PL_Xpv;
2639
2640     if (PL_savestack_ix + 15 <= PL_savestack_max)
2641         flags |= 1;
2642     if (PL_markstack_ptr < PL_markstack_max - 2)
2643         flags |= 4;
2644     if (PL_scopestack_ix < PL_scopestack_max - 3)
2645         flags |= 16;
2646
2647     if (!PL_psig_ptr[sig]) {
2648                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2649                                  PL_sig_name[sig]);
2650                 exit(sig);
2651         }
2652
2653     /* Max number of items pushed there is 3*n or 4. We cannot fix
2654        infinity, so we fix 4 (in fact 5): */
2655     if (flags & 1) {
2656         PL_savestack_ix += 5;           /* Protect save in progress. */
2657         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2658     }
2659     if (flags & 4)
2660         PL_markstack_ptr++;             /* Protect mark. */
2661     if (flags & 16)
2662         PL_scopestack_ix += 1;
2663     /* sv_2cv is too complicated, try a simpler variant first: */
2664     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2665         || SvTYPE(cv) != SVt_PVCV) {
2666         HV *st;
2667         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2668     }
2669
2670     if (!cv || !CvROOT(cv)) {
2671         if (ckWARN(WARN_SIGNAL))
2672             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2673                 PL_sig_name[sig], (gv ? GvENAME(gv)
2674                                 : ((cv && CvGV(cv))
2675                                    ? GvENAME(CvGV(cv))
2676                                    : "__ANON__")));
2677         goto cleanup;
2678     }
2679
2680     if(PL_psig_name[sig]) {
2681         sv = SvREFCNT_inc(PL_psig_name[sig]);
2682         flags |= 64;
2683 #if !defined(PERL_IMPLICIT_CONTEXT)
2684         PL_sig_sv = sv;
2685 #endif
2686     } else {
2687         sv = sv_newmortal();
2688         sv_setpv(sv,PL_sig_name[sig]);
2689     }
2690
2691     PUSHSTACKi(PERLSI_SIGNAL);
2692     PUSHMARK(SP);
2693     PUSHs(sv);
2694 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2695     {
2696          struct sigaction oact;
2697
2698          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2699               siginfo_t *sip;
2700               va_list args;
2701
2702               va_start(args, sig);
2703               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2704               if (sip) {
2705                    HV *sih = newHV();
2706                    SV *rv  = newRV_noinc((SV*)sih);
2707                    /* The siginfo fields signo, code, errno, pid, uid,
2708                     * addr, status, and band are defined by POSIX/SUSv3. */
2709                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2710                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2711 #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. */
2712                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2713                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2714                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2715                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2716                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2717                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2718 #endif
2719                    EXTEND(SP, 2);
2720                    PUSHs((SV*)rv);
2721                    PUSHs(newSVpv((void*)sip, sizeof(*sip)));
2722               }
2723
2724               va_end(args);
2725          }
2726     }
2727 #endif
2728     PUTBACK;
2729
2730     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2731
2732     POPSTACK;
2733     if (SvTRUE(ERRSV)) {
2734 #ifndef PERL_MICRO
2735 #ifdef HAS_SIGPROCMASK
2736         /* Handler "died", for example to get out of a restart-able read().
2737          * Before we re-do that on its behalf re-enable the signal which was
2738          * blocked by the system when we entered.
2739          */
2740         sigset_t set;
2741         sigemptyset(&set);
2742         sigaddset(&set,sig);
2743         sigprocmask(SIG_UNBLOCK, &set, NULL);
2744 #else
2745         /* Not clear if this will work */
2746         (void)rsignal(sig, SIG_IGN);
2747         (void)rsignal(sig, PL_csighandlerp);
2748 #endif
2749 #endif /* !PERL_MICRO */
2750         Perl_die(aTHX_ Nullch);
2751     }
2752 cleanup:
2753     if (flags & 1)
2754         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2755     if (flags & 4)
2756         PL_markstack_ptr--;
2757     if (flags & 16)
2758         PL_scopestack_ix -= 1;
2759     if (flags & 64)
2760         SvREFCNT_dec(sv);
2761     PL_op = myop;                       /* Apparently not needed... */
2762
2763     PL_Sv = tSv;                        /* Restore global temporaries. */
2764     PL_Xpv = tXpv;
2765     return;
2766 }
2767
2768
2769 static void
2770 S_restore_magic(pTHX_ const void *p)
2771 {
2772     dVAR;
2773     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2774     SV* const sv = mgs->mgs_sv;
2775
2776     if (!sv)
2777         return;
2778
2779     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2780     {
2781 #ifdef PERL_OLD_COPY_ON_WRITE
2782         /* While magic was saved (and off) sv_setsv may well have seen
2783            this SV as a prime candidate for COW.  */
2784         if (SvIsCOW(sv))
2785             sv_force_normal_flags(sv, 0);
2786 #endif
2787
2788         if (mgs->mgs_flags)
2789             SvFLAGS(sv) |= mgs->mgs_flags;
2790         else
2791             mg_magical(sv);
2792         if (SvGMAGICAL(sv)) {
2793             /* downgrade public flags to private,
2794                and discard any other private flags */
2795
2796             U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2797             if (public) {
2798                 SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
2799                 SvFLAGS(sv) |= ( public << PRIVSHIFT );
2800             }
2801         }
2802     }
2803
2804     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2805
2806     /* If we're still on top of the stack, pop us off.  (That condition
2807      * will be satisfied if restore_magic was called explicitly, but *not*
2808      * if it's being called via leave_scope.)
2809      * The reason for doing this is that otherwise, things like sv_2cv()
2810      * may leave alloc gunk on the savestack, and some code
2811      * (e.g. sighandler) doesn't expect that...
2812      */
2813     if (PL_savestack_ix == mgs->mgs_ss_ix)
2814     {
2815         I32 popval = SSPOPINT;
2816         assert(popval == SAVEt_DESTRUCTOR_X);
2817         PL_savestack_ix -= 2;
2818         popval = SSPOPINT;
2819         assert(popval == SAVEt_ALLOC);
2820         popval = SSPOPINT;
2821         PL_savestack_ix -= popval;
2822     }
2823
2824 }
2825
2826 static void
2827 S_unwind_handler_stack(pTHX_ const void *p)
2828 {
2829     dVAR;
2830     const U32 flags = *(const U32*)p;
2831
2832     if (flags & 1)
2833         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2834 #if !defined(PERL_IMPLICIT_CONTEXT)
2835     if (flags & 64)
2836         SvREFCNT_dec(PL_sig_sv);
2837 #endif
2838 }
2839
2840 /*
2841  * Local variables:
2842  * c-indentation-style: bsd
2843  * c-basic-offset: 4
2844  * indent-tabs-mode: t
2845  * End:
2846  *
2847  * ex: set ts=8 sts=4 sw=4 noet:
2848  */