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