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