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