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