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