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