mg.c

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