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