mg.c

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