mg.c

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