mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "Sam sat on the ground and put his head in his hands.  'I wish I had never
  13  * come here, and I don't want to see no more magic,' he said, and fell silent."
  14  */
  15
  16 /*
  17 =head1 Magical Functions
  18
  19 "Magic" is special data attached to SV structures in order to give them
  20 "magical" properties.  When any Perl code tries to read from, or assign to,
  21 an SV marked as magical, it calls the 'get' or 'set' function associated
  22 with that SV's magic. A get is called prior to reading an SV, in order to
  23 give it a chance to update its internal value (get on $. writes the line
  24 number of the last read filehandle into to the SV's IV slot), while
  25 set is called after an SV has been written to, in order to allow it to make
  26 use of its changed value (set on $/ copies the SV's new value to the
  27 PL_rs global variable).
  28
  29 Magic is implemented as a linked list of MAGIC structures attached to the
  30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
  31 of functions that implement the get(), set(), length() etc functions,
  32 plus space for some flags and pointers. For example, a tied variable has
  33 a MAGIC structure that contains a pointer to the object associated with the
  34 tie.
  35
  36 */
  37
  38 #include "EXTERN.h"
  39 #define PERL_IN_MG_C
  40 #include "perl.h"
  41
  42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
  43 #  ifdef I_GRP
  44 #    include <grp.h>
  45 #  endif
  46 #endif
  47
  48 #if defined(HAS_SETGROUPS)
  49 #  ifndef NGROUPS
  50 #    define NGROUPS 32
  51 #  endif
  52 #endif
  53
  54 #ifdef __hpux
  55 #  include <sys/pstat.h>
  56 #endif
  57
  58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
  59 Signal_t Perl_csighandler(int sig, ...);
  60 #else
  61 Signal_t Perl_csighandler(int sig);
  62 #endif
  63
  64 #ifdef __Lynx__
  65 /* Missing protos on LynxOS */
  66 void setruid(uid_t id);
  67 void seteuid(uid_t id);
  68 void setrgid(uid_t id);
  69 void setegid(uid_t id);
  70 #endif
  71
  72 /*
  73  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  74  */
  75
  76 struct magic_state {
  77     SV* mgs_sv;
  78     U32 mgs_flags;
  79     I32 mgs_ss_ix;
  80 };
  81 /* MGS is typedef'ed to struct magic_state in perl.h */
  82
  83 STATIC void
  84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
  85 {
  86     dVAR;
  87     MGS* mgs;
  88     assert(SvMAGICAL(sv));
  89     /* Turning READONLY off for a copy-on-write scalar (including shared
  90        hash keys) is a bad idea.  */
  91     if (SvIsCOW(sv))
  92       sv_force_normal_flags(sv, 0);
  93
  94     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
  95
  96     mgs = SSPTR(mgs_ix, MGS*);
  97     mgs->mgs_sv = sv;
  98     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  99     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
 100
 101     SvMAGICAL_off(sv);
 102     SvREADONLY_off(sv);
 103     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 104 }
 105
 106 /*
 107 =for apidoc mg_magical
 108
 109 Turns on the magical status of an SV.  See C<sv_magic>.
 110
 111 =cut
 112 */
 113
 114 void
 115 Perl_mg_magical(pTHX_ SV *sv)
 116 {
 117     const MAGIC* mg;
 118     PERL_UNUSED_CONTEXT;
 119     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 120         const MGVTBL* const vtbl = mg->mg_virtual;
 121         if (vtbl) {
 122             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 123                 SvGMAGICAL_on(sv);
 124             if (vtbl->svt_set)
 125                 SvSMAGICAL_on(sv);
 126             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
 127                 SvRMAGICAL_on(sv);
 128         }
 129     }
 130 }
 131
 132 /*
 133 =for apidoc mg_get
 134
 135 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 136
 137 =cut
 138 */
 139
 140 int
 141 Perl_mg_get(pTHX_ SV *sv)
 142 {
 143     dVAR;
 144     const I32 mgs_ix = SSNEW(sizeof(MGS));
 145     const bool was_temp = (bool)SvTEMP(sv);
 146     int have_new = 0;
 147     MAGIC *newmg, *head, *cur, *mg;
 148     /* guard against sv having being freed midway by holding a private
 149        reference. */
 150
 151     /* sv_2mortal has this side effect of turning on the TEMP flag, which can
 152        cause the SV's buffer to get stolen (and maybe other stuff).
 153        So restore it.
 154     */
 155     sv_2mortal(SvREFCNT_inc_simple_NN(sv));
 156     if (!was_temp) {
 157         SvTEMP_off(sv);
 158     }
 159
 160     save_magic(mgs_ix, sv);
 161
 162     /* We must call svt_get(sv, mg) for each valid entry in the linked
 163        list of magic. svt_get() may delete the current entry, add new
 164        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 165
 166     newmg = cur = head = mg = SvMAGIC(sv);
 167     while (mg) {
 168         const MGVTBL * const vtbl = mg->mg_virtual;
 169
 170         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 171             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 172
 173             /* guard against magic having been deleted - eg FETCH calling
 174              * untie */
 175             if (!SvMAGIC(sv))
 176                 break;
 177
 178             /* Don't restore the flags for this entry if it was deleted. */
 179             if (mg->mg_flags & MGf_GSKIP)
 180                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
 181         }
 182
 183         mg = mg->mg_moremagic;
 184
 185         if (have_new) {
 186             /* Have we finished with the new entries we saw? Start again
 187                where we left off (unless there are more new entries). */
 188             if (mg == head) {
 189                 have_new = 0;
 190                 mg   = cur;
 191                 head = newmg;
 192             }
 193         }
 194
 195         /* Were any new entries added? */
 196         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
 197             have_new = 1;
 198             cur = mg;
 199             mg  = newmg;
 200         }
 201     }
 202
 203     restore_magic(INT2PTR(void *, (IV)mgs_ix));
 204
 205     if (SvREFCNT(sv) == 1) {
 206         /* We hold the last reference to this SV, which implies that the
 207            SV was deleted as a side effect of the routines we called.  */
 208         SvOK_off(sv);
 209     }
 210     return 0;
 211 }
 212
 213 /*
 214 =for apidoc mg_set
 215
 216 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 217
 218 =cut
 219 */
 220
 221 int
 222 Perl_mg_set(pTHX_ SV *sv)
 223 {
 224     dVAR;
 225     const I32 mgs_ix = SSNEW(sizeof(MGS));
 226     MAGIC* mg;
 227     MAGIC* nextmg;
 228
 229     save_magic(mgs_ix, sv);
 230
 231     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 232         const MGVTBL* vtbl = mg->mg_virtual;
 233         nextmg = mg->mg_moremagic;      /* it may delete itself */
 234         if (mg->mg_flags & MGf_GSKIP) {
 235             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 236             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
 237         }
 238         if (vtbl && vtbl->svt_set)
 239             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
 240     }
 241
 242     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 243     return 0;
 244 }
 245
 246 /*
 247 =for apidoc mg_length
 248
 249 Report on the SV's length.  See C<sv_magic>.
 250
 251 =cut
 252 */
 253
 254 U32
 255 Perl_mg_length(pTHX_ SV *sv)
 256 {
 257     dVAR;
 258     MAGIC* mg;
 259     STRLEN len;
 260
 261     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 262         const MGVTBL * const vtbl = mg->mg_virtual;
 263         if (vtbl && vtbl->svt_len) {
 264             const I32 mgs_ix = SSNEW(sizeof(MGS));
 265             save_magic(mgs_ix, sv);
 266             /* omit MGf_GSKIP -- not changed here */
 267             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 268             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 269             return len;
 270         }
 271     }
 272
 273     if (DO_UTF8(sv)) {
 274         const U8 *s = (U8*)SvPV_const(sv, len);
 275         len = Perl_utf8_length(aTHX_ s, s + len);
 276     }
 277     else
 278         (void)SvPV_const(sv, len);
 279     return len;
 280 }
 281
 282 I32
 283 Perl_mg_size(pTHX_ SV *sv)
 284 {
 285     MAGIC* mg;
 286
 287     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 288         const MGVTBL* const vtbl = mg->mg_virtual;
 289         if (vtbl && vtbl->svt_len) {
 290             const I32 mgs_ix = SSNEW(sizeof(MGS));
 291             I32 len;
 292             save_magic(mgs_ix, sv);
 293             /* omit MGf_GSKIP -- not changed here */
 294             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 295             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 296             return len;
 297         }
 298     }
 299
 300     switch(SvTYPE(sv)) {
 301         case SVt_PVAV:
 302             return AvFILLp((AV *) sv); /* Fallback to non-tied array */
 303         case SVt_PVHV:
 304             /* FIXME */
 305         default:
 306             Perl_croak(aTHX_ "Size magic not implemented");
 307             break;
 308     }
 309     return 0;
 310 }
 311
 312 /*
 313 =for apidoc mg_clear
 314
 315 Clear something magical that the SV represents.  See C<sv_magic>.
 316
 317 =cut
 318 */
 319
 320 int
 321 Perl_mg_clear(pTHX_ SV *sv)
 322 {
 323     const I32 mgs_ix = SSNEW(sizeof(MGS));
 324     MAGIC* mg;
 325
 326     save_magic(mgs_ix, sv);
 327
 328     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 329         const MGVTBL* const vtbl = mg->mg_virtual;
 330         /* omit GSKIP -- never set here */
 331
 332         if (vtbl && vtbl->svt_clear)
 333             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 334     }
 335
 336     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 337     return 0;
 338 }
 339
 340 /*
 341 =for apidoc mg_find
 342
 343 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 344
 345 =cut
 346 */
 347
 348 MAGIC*
 349 Perl_mg_find(pTHX_ const SV *sv, int type)
 350 {
 351     PERL_UNUSED_CONTEXT;
 352     if (sv) {
 353         MAGIC *mg;
 354         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 355             if (mg->mg_type == type)
 356                 return mg;
 357         }
 358     }
 359     return NULL;
 360 }
 361
 362 /*
 363 =for apidoc mg_copy
 364
 365 Copies the magic from one SV to another.  See C<sv_magic>.
 366
 367 =cut
 368 */
 369
 370 int
 371 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 372 {
 373     int count = 0;
 374     MAGIC* mg;
 375     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 376         const MGVTBL* const vtbl = mg->mg_virtual;
 377         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 378             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 379         }
 380         else {
 381             const char type = mg->mg_type;
 382             if (isUPPER(type) && 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 = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
 535                     }
 536
 537                     sv_setiv(sv, i);
 538                 }
 539         }
 540     }
 541     return 0;
 542 }
 543
 544 int
 545 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 546 {
 547     PERL_UNUSED_ARG(sv);
 548     PERL_UNUSED_ARG(mg);
 549     Perl_croak(aTHX_ PL_no_modify);
 550     NORETURN_FUNCTION_END;
 551 }
 552
 553 U32
 554 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 555 {
 556     dVAR;
 557     register I32 paren;
 558     register I32 i;
 559     register const REGEXP *rx;
 560     I32 s1, t1;
 561
 562     switch (*mg->mg_ptr) {
 563     case '1': case '2': case '3': case '4':
 564     case '5': case '6': case '7': case '8': case '9': case '&':
 565         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 566
 567             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 568           getparen:
 569             if (paren <= (I32)rx->nparens &&
 570                 (s1 = rx->startp[paren]) != -1 &&
 571                 (t1 = rx->endp[paren]) != -1)
 572             {
 573                 i = t1 - s1;
 574               getlen:
 575                 if (i > 0 && RX_MATCH_UTF8(rx)) {
 576                     const char * const s = rx->subbeg + s1;
 577                     const U8 *ep;
 578                     STRLEN el;
 579
 580                     i = t1 - s1;
 581                     if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
 582                         i = el;
 583                 }
 584                 if (i < 0)
 585                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 586                 return i;
 587             }
 588             else {
 589                 if (ckWARN(WARN_UNINITIALIZED))
 590                     report_uninit(sv);
 591             }
 592         }
 593         else {
 594             if (ckWARN(WARN_UNINITIALIZED))
 595                 report_uninit(sv);
 596         }
 597         return 0;
 598     case '+':
 599         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 600             paren = rx->lastparen;
 601             if (paren)
 602                 goto getparen;
 603         }
 604         return 0;
 605     case '\016': /* ^N */
 606         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 607             paren = rx->lastcloseparen;
 608             if (paren)
 609                 goto getparen;
 610         }
 611         return 0;
 612     case '`':
 613         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 614             if (rx->startp[0] != -1) {
 615                 i = rx->startp[0];
 616                 if (i > 0) {
 617                     s1 = 0;
 618                     t1 = i;
 619                     goto getlen;
 620                 }
 621             }
 622         }
 623         return 0;
 624     case '\'':
 625         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 626             if (rx->endp[0] != -1) {
 627                 i = rx->sublen - rx->endp[0];
 628                 if (i > 0) {
 629                     s1 = rx->endp[0];
 630                     t1 = rx->sublen;
 631                     goto getlen;
 632                 }
 633             }
 634         }
 635         return 0;
 636     }
 637     magic_get(sv,mg);
 638     if (!SvPOK(sv) && SvNIOK(sv)) {
 639         sv_2pv(sv, 0);
 640     }
 641     if (SvPOK(sv))
 642         return SvCUR(sv);
 643     return 0;
 644 }
 645
 646 #define SvRTRIM(sv) STMT_START { \
 647     if (SvPOK(sv)) { \
 648         STRLEN len = SvCUR(sv); \
 649         char * const p = SvPVX(sv); \
 650         while (len > 0 && isSPACE(p[len-1])) \
 651            --len; \
 652         SvCUR_set(sv, len); \
 653         p[len] = '\0'; \
 654     } \
 655 } STMT_END
 656
 657 int
 658 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 659 {
 660     dVAR;
 661     register I32 paren;
 662     register char *s = NULL;
 663     register I32 i;
 664     register REGEXP *rx;
 665     const char * const remaining = mg->mg_ptr + 1;
 666     const char nextchar = *remaining;
 667
 668     switch (*mg->mg_ptr) {
 669     case '\001':                /* ^A */
 670         sv_setsv(sv, PL_bodytarget);
 671         break;
 672     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 673         if (nextchar == '\0') {
 674             sv_setiv(sv, (IV)PL_minus_c);
 675         }
 676         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 677             sv_setiv(sv, (IV)STATUS_NATIVE);
 678         }
 679         break;
 680
 681     case '\004':                /* ^D */
 682         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 683         break;
 684     case '\005':  /* ^E */
 685          if (nextchar == '\0') {
 686 #if defined(MACOS_TRADITIONAL)
 687              {
 688                   char msg[256];
 689
 690                   sv_setnv(sv,(double)gMacPerl_OSErr);
 691                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 692              }
 693 #elif defined(VMS)
 694              {
 695 #                 include <descrip.h>
 696 #                 include <starlet.h>
 697                   char msg[255];
 698                   $DESCRIPTOR(msgdsc,msg);
 699                   sv_setnv(sv,(NV) vaxc$errno);
 700                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 701                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 702                   else
 703                        sv_setpvn(sv,"",0);
 704              }
 705 #elif defined(OS2)
 706              if (!(_emx_env & 0x200)) { /* Under DOS */
 707                   sv_setnv(sv, (NV)errno);
 708                   sv_setpv(sv, errno ? Strerror(errno) : "");
 709              } else {
 710                   if (errno != errno_isOS2) {
 711                        const int tmp = _syserrno();
 712                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 713                             Perl_rc = tmp;
 714                   }
 715                   sv_setnv(sv, (NV)Perl_rc);
 716                   sv_setpv(sv, os2error(Perl_rc));
 717              }
 718 #elif defined(WIN32)
 719              {
 720                   const DWORD dwErr = GetLastError();
 721                   sv_setnv(sv, (NV)dwErr);
 722                   if (dwErr) {
 723                        PerlProc_GetOSError(sv, dwErr);
 724                   }
 725                   else
 726                        sv_setpvn(sv, "", 0);
 727                   SetLastError(dwErr);
 728              }
 729 #else
 730              {
 731                  const int saveerrno = errno;
 732                  sv_setnv(sv, (NV)errno);
 733                  sv_setpv(sv, errno ? Strerror(errno) : "");
 734                  errno = saveerrno;
 735              }
 736 #endif
 737              SvRTRIM(sv);
 738              SvNOK_on(sv);      /* what a wonderful hack! */
 739          }
 740          else if (strEQ(remaining, "NCODING"))
 741               sv_setsv(sv, PL_encoding);
 742          break;
 743     case '\006':                /* ^F */
 744         sv_setiv(sv, (IV)PL_maxsysfd);
 745         break;
 746     case '\010':                /* ^H */
 747         sv_setiv(sv, (IV)PL_hints);
 748         break;
 749     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 750         if (PL_inplace)
 751             sv_setpv(sv, PL_inplace);
 752         else
 753             sv_setsv(sv, &PL_sv_undef);
 754         break;
 755     case '\017':                /* ^O & ^OPEN */
 756         if (nextchar == '\0') {
 757             sv_setpv(sv, PL_osname);
 758             SvTAINTED_off(sv);
 759         }
 760         else if (strEQ(remaining, "PEN")) {
 761             if (!(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                 SV **bits_all;
 823                 HV * const bits=get_hv("warnings::Bits", FALSE);
 824                 if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
 825                     sv_setsv(sv, *bits_all);
 826                 }
 827                 else {
 828                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 829                 }
 830             }
 831             else {
 832                 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
 833                           *PL_compiling.cop_warnings);
 834             }
 835             SvPOK_only(sv);
 836         }
 837         break;
 838     case '1': case '2': case '3': case '4':
 839     case '5': case '6': case '7': case '8': case '9': case '&':
 840         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 841             I32 s1, t1;
 842
 843             /*
 844              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 845              * XXX Does the new way break anything?
 846              */
 847             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 848           getparen:
 849             if (paren <= (I32)rx->nparens &&
 850                 (s1 = rx->startp[paren]) != -1 &&
 851                 (t1 = rx->endp[paren]) != -1)
 852             {
 853                 i = t1 - s1;
 854                 s = rx->subbeg + s1;
 855                 assert(rx->subbeg);
 856
 857               getrx:
 858                 if (i >= 0) {
 859                     const int oldtainted = PL_tainted;
 860                     TAINT_NOT;
 861                     sv_setpvn(sv, s, i);
 862                     PL_tainted = oldtainted;
 863                     if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
 864                         SvUTF8_on(sv);
 865                     else
 866                         SvUTF8_off(sv);
 867                     if (PL_tainting) {
 868                         if (RX_MATCH_TAINTED(rx)) {
 869                             MAGIC* const mg = SvMAGIC(sv);
 870                             MAGIC* mgt;
 871                             PL_tainted = 1;
 872                             SvMAGIC_set(sv, mg->mg_moremagic);
 873                             SvTAINT(sv);
 874                             if ((mgt = SvMAGIC(sv))) {
 875                                 mg->mg_moremagic = mgt;
 876                                 SvMAGIC_set(sv, mg);
 877                             }
 878                         } else
 879                             SvTAINTED_off(sv);
 880                     }
 881                     break;
 882                 }
 883             }
 884         }
 885         sv_setsv(sv,&PL_sv_undef);
 886         break;
 887     case '+':
 888         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 889             paren = rx->lastparen;
 890             if (paren)
 891                 goto getparen;
 892         }
 893         sv_setsv(sv,&PL_sv_undef);
 894         break;
 895     case '\016':                /* ^N */
 896         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 897             paren = rx->lastcloseparen;
 898             if (paren)
 899                 goto getparen;
 900         }
 901         sv_setsv(sv,&PL_sv_undef);
 902         break;
 903     case '`':
 904         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 905             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 906                 i = rx->startp[0];
 907                 goto getrx;
 908             }
 909         }
 910         sv_setsv(sv,&PL_sv_undef);
 911         break;
 912     case '\'':
 913         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 914             if (rx->subbeg && rx->endp[0] != -1) {
 915                 s = rx->subbeg + rx->endp[0];
 916                 i = rx->sublen - rx->endp[0];
 917                 goto getrx;
 918             }
 919         }
 920         sv_setsv(sv,&PL_sv_undef);
 921         break;
 922     case '.':
 923         if (GvIO(PL_last_in_gv)) {
 924             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 925         }
 926         break;
 927     case '?':
 928         {
 929             sv_setiv(sv, (IV)STATUS_CURRENT);
 930 #ifdef COMPLEX_STATUS
 931             LvTARGOFF(sv) = PL_statusvalue;
 932             LvTARGLEN(sv) = PL_statusvalue_vms;
 933 #endif
 934         }
 935         break;
 936     case '^':
 937         if (GvIOp(PL_defoutgv))
 938             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 939         if (s)
 940             sv_setpv(sv,s);
 941         else {
 942             sv_setpv(sv,GvENAME(PL_defoutgv));
 943             sv_catpv(sv,"_TOP");
 944         }
 945         break;
 946     case '~':
 947         if (GvIOp(PL_defoutgv))
 948             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 949         if (!s)
 950             s = GvENAME(PL_defoutgv);
 951         sv_setpv(sv,s);
 952         break;
 953     case '=':
 954         if (GvIOp(PL_defoutgv))
 955             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 956         break;
 957     case '-':
 958         if (GvIOp(PL_defoutgv))
 959             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 960         break;
 961     case '%':
 962         if (GvIOp(PL_defoutgv))
 963             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 964         break;
 965     case ':':
 966         break;
 967     case '/':
 968         break;
 969     case '[':
 970         WITH_THR(sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)));
 971         break;
 972     case '|':
 973         if (GvIOp(PL_defoutgv))
 974             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 975         break;
 976     case ',':
 977         break;
 978     case '\\':
 979         if (PL_ors_sv)
 980             sv_copypv(sv, PL_ors_sv);
 981         break;
 982     case '!':
 983 #ifdef VMS
 984         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 985         sv_setpv(sv, errno ? Strerror(errno) : "");
 986 #else
 987         {
 988         const int saveerrno = errno;
 989         sv_setnv(sv, (NV)errno);
 990 #ifdef OS2
 991         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 992             sv_setpv(sv, os2error(Perl_rc));
 993         else
 994 #endif
 995         sv_setpv(sv, errno ? Strerror(errno) : "");
 996         errno = saveerrno;
 997         }
 998 #endif
 999         SvRTRIM(sv);
1000         SvNOK_on(sv);   /* what a wonderful hack! */
1001         break;
1002     case '<':
1003         sv_setiv(sv, (IV)PL_uid);
1004         break;
1005     case '>':
1006         sv_setiv(sv, (IV)PL_euid);
1007         break;
1008     case '(':
1009         sv_setiv(sv, (IV)PL_gid);
1010         goto add_groups;
1011     case ')':
1012         sv_setiv(sv, (IV)PL_egid);
1013       add_groups:
1014 #ifdef HAS_GETGROUPS
1015         {
1016             Groups_t *gary = NULL;
1017             I32 i, num_groups = getgroups(0, gary);
1018             Newx(gary, num_groups, Groups_t);
1019             num_groups = getgroups(num_groups, gary);
1020             for (i = 0; i < num_groups; i++)
1021                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1022             Safefree(gary);
1023         }
1024         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1025 #endif
1026         break;
1027 #ifndef MACOS_TRADITIONAL
1028     case '0':
1029         break;
1030 #endif
1031     }
1032     return 0;
1033 }
1034
1035 int
1036 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1037 {
1038     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1039
1040     if (uf && uf->uf_val)
1041         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1042     return 0;
1043 }
1044
1045 int
1046 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1047 {
1048     dVAR;
1049     STRLEN len = 0, klen;
1050     const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1051     const char * const ptr = MgPV_const(mg,klen);
1052     my_setenv(ptr, s);
1053
1054 #ifdef DYNAMIC_ENV_FETCH
1055      /* We just undefd an environment var.  Is a replacement */
1056      /* waiting in the wings? */
1057     if (!len) {
1058         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1059         if (valp)
1060             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1061     }
1062 #endif
1063
1064 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1065                             /* And you'll never guess what the dog had */
1066                             /*   in its mouth... */
1067     if (PL_tainting) {
1068         MgTAINTEDDIR_off(mg);
1069 #ifdef VMS
1070         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1071             char pathbuf[256], eltbuf[256], *cp, *elt;
1072             Stat_t sbuf;
1073             int i = 0, j = 0;
1074
1075             strncpy(eltbuf, s, 255);
1076             eltbuf[255] = 0;
1077             elt = eltbuf;
1078             do {          /* DCL$PATH may be a search list */
1079                 while (1) {   /* as may dev portion of any element */
1080                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1081                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1082                              cando_by_name(S_IWUSR,0,elt) ) {
1083                             MgTAINTEDDIR_on(mg);
1084                             return 0;
1085                         }
1086                     }
1087                     if ((cp = strchr(elt, ':')) != NULL)
1088                         *cp = '\0';
1089                     if (my_trnlnm(elt, eltbuf, j++))
1090                         elt = eltbuf;
1091                     else
1092                         break;
1093                 }
1094                 j = 0;
1095             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1096         }
1097 #endif /* VMS */
1098         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1099             const char * const strend = s + len;
1100 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1101             const char path_sep = '|';
1102 #else
1103             const char path_sep = ':';
1104 #endif
1105
1106             while (s < strend) {
1107                 char tmpbuf[256];
1108                 Stat_t st;
1109                 I32 i;
1110                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1111                              s, strend, path_sep, &i);
1112                 s++;
1113                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1114 #ifdef VMS
1115                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1116 #else
1117                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1118 #endif
1119                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1120                     MgTAINTEDDIR_on(mg);
1121                     return 0;
1122                 }
1123             }
1124         }
1125     }
1126 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1127
1128     return 0;
1129 }
1130
1131 int
1132 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1133 {
1134     PERL_UNUSED_ARG(sv);
1135     my_setenv(MgPV_nolen_const(mg),NULL);
1136     return 0;
1137 }
1138
1139 int
1140 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1141 {
1142     dVAR;
1143     PERL_UNUSED_ARG(mg);
1144 #if defined(VMS)
1145     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1146 #else
1147     if (PL_localizing) {
1148         HE* entry;
1149         my_clearenv();
1150         hv_iterinit((HV*)sv);
1151         while ((entry = hv_iternext((HV*)sv))) {
1152             I32 keylen;
1153             my_setenv(hv_iterkey(entry, &keylen),
1154                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1155         }
1156     }
1157 #endif
1158     return 0;
1159 }
1160
1161 int
1162 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1163 {
1164     dVAR;
1165     PERL_UNUSED_ARG(sv);
1166     PERL_UNUSED_ARG(mg);
1167 #if defined(VMS)
1168     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1169 #else
1170     my_clearenv();
1171 #endif
1172     return 0;
1173 }
1174
1175 #ifndef PERL_MICRO
1176 #ifdef HAS_SIGPROCMASK
1177 static void
1178 restore_sigmask(pTHX_ SV *save_sv)
1179 {
1180     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1181     (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1182 }
1183 #endif
1184 int
1185 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1186 {
1187     dVAR;
1188     /* Are we fetching a signal entry? */
1189     const I32 i = whichsig(MgPV_nolen_const(mg));
1190     if (i > 0) {
1191         if(PL_psig_ptr[i])
1192             sv_setsv(sv,PL_psig_ptr[i]);
1193         else {
1194             Sighandler_t sigstate = rsignal_state(i);
1195 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1196             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1197                 sigstate = SIG_IGN;
1198 #endif
1199 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1200             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1201                 sigstate = SIG_DFL;
1202 #endif
1203             /* cache state so we don't fetch it again */
1204             if(sigstate == (Sighandler_t) SIG_IGN)
1205                 sv_setpv(sv,"IGNORE");
1206             else
1207                 sv_setsv(sv,&PL_sv_undef);
1208             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1209             SvTEMP_off(sv);
1210         }
1211     }
1212     return 0;
1213 }
1214 int
1215 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1216 {
1217     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1218      * refactoring might be in order.
1219      */
1220     dVAR;
1221     register const char * const s = MgPV_nolen_const(mg);
1222     PERL_UNUSED_ARG(sv);
1223     if (*s == '_') {
1224         SV** svp = NULL;
1225         if (strEQ(s,"__DIE__"))
1226             svp = &PL_diehook;
1227         else if (strEQ(s,"__WARN__"))
1228             svp = &PL_warnhook;
1229         else
1230             Perl_croak(aTHX_ "No such hook: %s", s);
1231         if (svp && *svp) {
1232             SV * const to_dec = *svp;
1233             *svp = NULL;
1234             SvREFCNT_dec(to_dec);
1235         }
1236     }
1237     else {
1238         /* Are we clearing a signal entry? */
1239         const I32 i = whichsig(s);
1240         if (i > 0) {
1241 #ifdef HAS_SIGPROCMASK
1242             sigset_t set, save;
1243             SV* save_sv;
1244             /* Avoid having the signal arrive at a bad time, if possible. */
1245             sigemptyset(&set);
1246             sigaddset(&set,i);
1247             sigprocmask(SIG_BLOCK, &set, &save);
1248             ENTER;
1249             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1250             SAVEFREESV(save_sv);
1251             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1252 #endif
1253             PERL_ASYNC_CHECK();
1254 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1255             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1256 #endif
1257 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1258             PL_sig_defaulting[i] = 1;
1259             (void)rsignal(i, PL_csighandlerp);
1260 #else
1261             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1262 #endif
1263             if(PL_psig_name[i]) {
1264                 SvREFCNT_dec(PL_psig_name[i]);
1265                 PL_psig_name[i]=0;
1266             }
1267             if(PL_psig_ptr[i]) {
1268                 SV * const to_dec=PL_psig_ptr[i];
1269                 PL_psig_ptr[i]=0;
1270                 LEAVE;
1271                 SvREFCNT_dec(to_dec);
1272             }
1273             else
1274                 LEAVE;
1275         }
1276     }
1277     return 0;
1278 }
1279
1280 static void
1281 S_raise_signal(pTHX_ int sig)
1282 {
1283     dVAR;
1284     /* Set a flag to say this signal is pending */
1285     PL_psig_pend[sig]++;
1286     /* And one to say _a_ signal is pending */
1287     PL_sig_pending = 1;
1288 }
1289
1290 Signal_t
1291 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1292 Perl_csighandler(int sig, ...)
1293 #else
1294 Perl_csighandler(int sig)
1295 #endif
1296 {
1297 #ifdef PERL_GET_SIG_CONTEXT
1298     dTHXa(PERL_GET_SIG_CONTEXT);
1299 #else
1300     dTHX;
1301 #endif
1302 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1303     (void) rsignal(sig, PL_csighandlerp);
1304     if (PL_sig_ignoring[sig]) return;
1305 #endif
1306 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1307     if (PL_sig_defaulting[sig])
1308 #ifdef KILL_BY_SIGPRC
1309             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1310 #else
1311             exit(1);
1312 #endif
1313 #endif
1314    if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1315         /* Call the perl level handler now--
1316          * with risk we may be in malloc() etc. */
1317         (*PL_sighandlerp)(sig);
1318    else
1319         S_raise_signal(aTHX_ sig);
1320 }
1321
1322 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1323 void
1324 Perl_csighandler_init(void)
1325 {
1326     int sig;
1327     if (PL_sig_handlers_initted) return;
1328
1329     for (sig = 1; sig < SIG_SIZE; sig++) {
1330 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1331         dTHX;
1332         PL_sig_defaulting[sig] = 1;
1333         (void) rsignal(sig, PL_csighandlerp);
1334 #endif
1335 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1336         PL_sig_ignoring[sig] = 0;
1337 #endif
1338     }
1339     PL_sig_handlers_initted = 1;
1340 }
1341 #endif
1342
1343 void
1344 Perl_despatch_signals(pTHX)
1345 {
1346     dVAR;
1347     int sig;
1348     PL_sig_pending = 0;
1349     for (sig = 1; sig < SIG_SIZE; sig++) {
1350         if (PL_psig_pend[sig]) {
1351             PERL_BLOCKSIG_ADD(set, sig);
1352             PL_psig_pend[sig] = 0;
1353             PERL_BLOCKSIG_BLOCK(set);
1354             (*PL_sighandlerp)(sig);
1355             PERL_BLOCKSIG_UNBLOCK(set);
1356         }
1357     }
1358 }
1359
1360 int
1361 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1362 {
1363     dVAR;
1364     I32 i;
1365     SV** svp = NULL;
1366     /* Need to be careful with SvREFCNT_dec(), because that can have side
1367      * effects (due to closures). We must make sure that the new disposition
1368      * is in place before it is called.
1369      */
1370     SV* to_dec = NULL;
1371     STRLEN len;
1372 #ifdef HAS_SIGPROCMASK
1373     sigset_t set, save;
1374     SV* save_sv;
1375 #endif
1376
1377     register const char *s = MgPV_const(mg,len);
1378     if (*s == '_') {
1379         if (strEQ(s,"__DIE__"))
1380             svp = &PL_diehook;
1381         else if (strEQ(s,"__WARN__"))
1382             svp = &PL_warnhook;
1383         else
1384             Perl_croak(aTHX_ "No such hook: %s", s);
1385         i = 0;
1386         if (*svp) {
1387             to_dec = *svp;
1388             *svp = NULL;
1389         }
1390     }
1391     else {
1392         i = whichsig(s);        /* ...no, a brick */
1393         if (i <= 0) {
1394             if (ckWARN(WARN_SIGNAL))
1395                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1396             return 0;
1397         }
1398 #ifdef HAS_SIGPROCMASK
1399         /* Avoid having the signal arrive at a bad time, if possible. */
1400         sigemptyset(&set);
1401         sigaddset(&set,i);
1402         sigprocmask(SIG_BLOCK, &set, &save);
1403         ENTER;
1404         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1405         SAVEFREESV(save_sv);
1406         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1407 #endif
1408         PERL_ASYNC_CHECK();
1409 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1410         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1411 #endif
1412 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1413         PL_sig_ignoring[i] = 0;
1414 #endif
1415 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1416         PL_sig_defaulting[i] = 0;
1417 #endif
1418         SvREFCNT_dec(PL_psig_name[i]);
1419         to_dec = PL_psig_ptr[i];
1420         PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1421         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1422         PL_psig_name[i] = newSVpvn(s, len);
1423         SvREADONLY_on(PL_psig_name[i]);
1424     }
1425     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1426         if (i) {
1427             (void)rsignal(i, PL_csighandlerp);
1428 #ifdef HAS_SIGPROCMASK
1429             LEAVE;
1430 #endif
1431         }
1432         else
1433             *svp = SvREFCNT_inc_simple_NN(sv);
1434         if(to_dec)
1435             SvREFCNT_dec(to_dec);
1436         return 0;
1437     }
1438     s = SvPV_force(sv,len);
1439     if (strEQ(s,"IGNORE")) {
1440         if (i) {
1441 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1442             PL_sig_ignoring[i] = 1;
1443             (void)rsignal(i, PL_csighandlerp);
1444 #else
1445             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1446 #endif
1447         }
1448     }
1449     else if (strEQ(s,"DEFAULT") || !*s) {
1450         if (i)
1451 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1452           {
1453             PL_sig_defaulting[i] = 1;
1454             (void)rsignal(i, PL_csighandlerp);
1455           }
1456 #else
1457             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1458 #endif
1459     }
1460     else {
1461         /*
1462          * We should warn if HINT_STRICT_REFS, but without
1463          * access to a known hint bit in a known OP, we can't
1464          * tell whether HINT_STRICT_REFS is in force or not.
1465          */
1466         if (!strchr(s,':') && !strchr(s,'\''))
1467             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1468         if (i)
1469             (void)rsignal(i, PL_csighandlerp);
1470         else
1471             *svp = SvREFCNT_inc_simple_NN(sv);
1472     }
1473 #ifdef HAS_SIGPROCMASK
1474     if(i)
1475         LEAVE;
1476 #endif
1477     if(to_dec)
1478         SvREFCNT_dec(to_dec);
1479     return 0;
1480 }
1481 #endif /* !PERL_MICRO */
1482
1483 int
1484 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1485 {
1486     dVAR;
1487     PERL_UNUSED_ARG(sv);
1488     PERL_UNUSED_ARG(mg);
1489     PL_sub_generation++;
1490     return 0;
1491 }
1492
1493 int
1494 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1495 {
1496     dVAR;
1497     PERL_UNUSED_ARG(sv);
1498     PERL_UNUSED_ARG(mg);
1499     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1500     PL_amagic_generation++;
1501
1502     return 0;
1503 }
1504
1505 int
1506 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1507 {
1508     HV * const hv = (HV*)LvTARG(sv);
1509     I32 i = 0;
1510     PERL_UNUSED_ARG(mg);
1511
1512     if (hv) {
1513          (void) hv_iterinit(hv);
1514          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1515              i = HvKEYS(hv);
1516          else {
1517              while (hv_iternext(hv))
1518                  i++;
1519          }
1520     }
1521
1522     sv_setiv(sv, (IV)i);
1523     return 0;
1524 }
1525
1526 int
1527 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1528 {
1529     PERL_UNUSED_ARG(mg);
1530     if (LvTARG(sv)) {
1531         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1532     }
1533     return 0;
1534 }
1535
1536 /* caller is responsible for stack switching/cleanup */
1537 STATIC int
1538 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1539 {
1540     dVAR;
1541     dSP;
1542
1543     PUSHMARK(SP);
1544     EXTEND(SP, n);
1545     PUSHs(SvTIED_obj(sv, mg));
1546     if (n > 1) {
1547         if (mg->mg_ptr) {
1548             if (mg->mg_len >= 0)
1549                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1550             else if (mg->mg_len == HEf_SVKEY)
1551                 PUSHs((SV*)mg->mg_ptr);
1552         }
1553         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1554             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1555         }
1556     }
1557     if (n > 2) {
1558         PUSHs(val);
1559     }
1560     PUTBACK;
1561
1562     return call_method(meth, flags);
1563 }
1564
1565 STATIC int
1566 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1567 {
1568     dVAR; dSP;
1569
1570     ENTER;
1571     SAVETMPS;
1572     PUSHSTACKi(PERLSI_MAGIC);
1573
1574     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1575         sv_setsv(sv, *PL_stack_sp--);
1576     }
1577
1578     POPSTACK;
1579     FREETMPS;
1580     LEAVE;
1581     return 0;
1582 }
1583
1584 int
1585 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1586 {
1587     if (mg->mg_ptr)
1588         mg->mg_flags |= MGf_GSKIP;
1589     magic_methpack(sv,mg,"FETCH");
1590     return 0;
1591 }
1592
1593 int
1594 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1595 {
1596     dVAR; dSP;
1597     ENTER;
1598     PUSHSTACKi(PERLSI_MAGIC);
1599     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1600     POPSTACK;
1601     LEAVE;
1602     return 0;
1603 }
1604
1605 int
1606 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1607 {
1608     return magic_methpack(sv,mg,"DELETE");
1609 }
1610
1611
1612 U32
1613 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1614 {
1615     dVAR; dSP;
1616     U32 retval = 0;
1617
1618     ENTER;
1619     SAVETMPS;
1620     PUSHSTACKi(PERLSI_MAGIC);
1621     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1622         sv = *PL_stack_sp--;
1623         retval = (U32) SvIV(sv)-1;
1624     }
1625     POPSTACK;
1626     FREETMPS;
1627     LEAVE;
1628     return retval;
1629 }
1630
1631 int
1632 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1633 {
1634     dVAR; dSP;
1635
1636     ENTER;
1637     PUSHSTACKi(PERLSI_MAGIC);
1638     PUSHMARK(SP);
1639     XPUSHs(SvTIED_obj(sv, mg));
1640     PUTBACK;
1641     call_method("CLEAR", G_SCALAR|G_DISCARD);
1642     POPSTACK;
1643     LEAVE;
1644
1645     return 0;
1646 }
1647
1648 int
1649 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1650 {
1651     dVAR; dSP;
1652     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1653
1654     ENTER;
1655     SAVETMPS;
1656     PUSHSTACKi(PERLSI_MAGIC);
1657     PUSHMARK(SP);
1658     EXTEND(SP, 2);
1659     PUSHs(SvTIED_obj(sv, mg));
1660     if (SvOK(key))
1661         PUSHs(key);
1662     PUTBACK;
1663
1664     if (call_method(meth, G_SCALAR))
1665         sv_setsv(key, *PL_stack_sp--);
1666
1667     POPSTACK;
1668     FREETMPS;
1669     LEAVE;
1670     return 0;
1671 }
1672
1673 int
1674 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1675 {
1676     return magic_methpack(sv,mg,"EXISTS");
1677 }
1678
1679 SV *
1680 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1681 {
1682     dVAR; dSP;
1683     SV *retval;
1684     SV * const tied = SvTIED_obj((SV*)hv, mg);
1685     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1686
1687     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1688         SV *key;
1689         if (HvEITER_get(hv))
1690             /* we are in an iteration so the hash cannot be empty */
1691             return &PL_sv_yes;
1692         /* no xhv_eiter so now use FIRSTKEY */
1693         key = sv_newmortal();
1694         magic_nextpack((SV*)hv, mg, key);
1695         HvEITER_set(hv, NULL);     /* need to reset iterator */
1696         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1697     }
1698
1699     /* there is a SCALAR method that we can call */
1700     ENTER;
1701     PUSHSTACKi(PERLSI_MAGIC);
1702     PUSHMARK(SP);
1703     EXTEND(SP, 1);
1704     PUSHs(tied);
1705     PUTBACK;
1706
1707     if (call_method("SCALAR", G_SCALAR))
1708         retval = *PL_stack_sp--;
1709     else
1710         retval = &PL_sv_undef;
1711     POPSTACK;
1712     LEAVE;
1713     return retval;
1714 }
1715
1716 int
1717 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1718 {
1719     dVAR;
1720     GV * const gv = PL_DBline;
1721     const I32 i = SvTRUE(sv);
1722     SV ** const svp = av_fetch(GvAV(gv),
1723                      atoi(MgPV_nolen_const(mg)), FALSE);
1724     if (svp && SvIOKp(*svp)) {
1725         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1726         if (o) {
1727             /* set or clear breakpoint in the relevant control op */
1728             if (i)
1729                 o->op_flags |= OPf_SPECIAL;
1730             else
1731                 o->op_flags &= ~OPf_SPECIAL;
1732         }
1733     }
1734     return 0;
1735 }
1736
1737 int
1738 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1739 {
1740     dVAR;
1741     const AV * const obj = (AV*)mg->mg_obj;
1742     if (obj) {
1743         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1744     } else {
1745         SvOK_off(sv);
1746     }
1747     return 0;
1748 }
1749
1750 int
1751 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1752 {
1753     dVAR;
1754     AV * const obj = (AV*)mg->mg_obj;
1755     if (obj) {
1756         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1757     } else {
1758         if (ckWARN(WARN_MISC))
1759             Perl_warner(aTHX_ packWARN(WARN_MISC),
1760                         "Attempt to set length of freed array");
1761     }
1762     return 0;
1763 }
1764
1765 int
1766 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1767 {
1768     dVAR;
1769     PERL_UNUSED_ARG(sv);
1770     /* during global destruction, mg_obj may already have been freed */
1771     if (PL_in_clean_all)
1772         return 0;
1773
1774     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1775
1776     if (mg) {
1777         /* arylen scalar holds a pointer back to the array, but doesn't own a
1778            reference. Hence the we (the array) are about to go away with it
1779            still pointing at us. Clear its pointer, else it would be pointing
1780            at free memory. See the comment in sv_magic about reference loops,
1781            and why it can't own a reference to us.  */
1782         mg->mg_obj = 0;
1783     }
1784     return 0;
1785 }
1786
1787 int
1788 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1789 {
1790     dVAR;
1791     SV* const lsv = LvTARG(sv);
1792     PERL_UNUSED_ARG(mg);
1793
1794     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1795         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1796         if (found && found->mg_len >= 0) {
1797             I32 i = found->mg_len;
1798             if (DO_UTF8(lsv))
1799                 sv_pos_b2u(lsv, &i);
1800             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1801             return 0;
1802         }
1803     }
1804     SvOK_off(sv);
1805     return 0;
1806 }
1807
1808 int
1809 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1810 {
1811     dVAR;
1812     SV* const lsv = LvTARG(sv);
1813     SSize_t pos;
1814     STRLEN len;
1815     STRLEN ulen = 0;
1816     MAGIC *found;
1817
1818     PERL_UNUSED_ARG(mg);
1819
1820     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1821         found = mg_find(lsv, PERL_MAGIC_regex_global);
1822     else
1823         found = NULL;
1824     if (!found) {
1825         if (!SvOK(sv))
1826             return 0;
1827 #ifdef PERL_OLD_COPY_ON_WRITE
1828     if (SvIsCOW(lsv))
1829         sv_force_normal_flags(lsv, 0);
1830 #endif
1831         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1832                          NULL, 0);
1833     }
1834     else if (!SvOK(sv)) {
1835         found->mg_len = -1;
1836         return 0;
1837     }
1838     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1839
1840     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1841
1842     if (DO_UTF8(lsv)) {
1843         ulen = sv_len_utf8(lsv);
1844         if (ulen)
1845             len = ulen;
1846     }
1847
1848     if (pos < 0) {
1849         pos += len;
1850         if (pos < 0)
1851             pos = 0;
1852     }
1853     else if (pos > (SSize_t)len)
1854         pos = len;
1855
1856     if (ulen) {
1857         I32 p = pos;
1858         sv_pos_u2b(lsv, &p, 0);
1859         pos = p;
1860     }
1861
1862     found->mg_len = pos;
1863     found->mg_flags &= ~MGf_MINMATCH;
1864
1865     return 0;
1866 }
1867
1868 int
1869 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1870 {
1871     GV* gv;
1872     PERL_UNUSED_ARG(mg);
1873
1874     if (!SvOK(sv))
1875         return 0;
1876     if (SvFLAGS(sv) & SVp_SCREAM
1877         && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
1878         /* We're actually already a typeglob, so don't need the stuff below.
1879          */
1880         return 0;
1881     }
1882     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1883     if (sv == (SV*)gv)
1884         return 0;
1885     if (GvGP(sv))
1886         gp_free((GV*)sv);
1887     GvGP(sv) = gp_ref(GvGP(gv));
1888     return 0;
1889 }
1890
1891 int
1892 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1893 {
1894     STRLEN len;
1895     SV * const lsv = LvTARG(sv);
1896     const char * const tmps = SvPV_const(lsv,len);
1897     I32 offs = LvTARGOFF(sv);
1898     I32 rem = LvTARGLEN(sv);
1899     PERL_UNUSED_ARG(mg);
1900
1901     if (SvUTF8(lsv))
1902         sv_pos_u2b(lsv, &offs, &rem);
1903     if (offs > (I32)len)
1904         offs = len;
1905     if (rem + offs > (I32)len)
1906         rem = len - offs;
1907     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1908     if (SvUTF8(lsv))
1909         SvUTF8_on(sv);
1910     return 0;
1911 }
1912
1913 int
1914 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1915 {
1916     dVAR;
1917     STRLEN len;
1918     const char * const tmps = SvPV_const(sv, len);
1919     SV * const lsv = LvTARG(sv);
1920     I32 lvoff = LvTARGOFF(sv);
1921     I32 lvlen = LvTARGLEN(sv);
1922     PERL_UNUSED_ARG(mg);
1923
1924     if (DO_UTF8(sv)) {
1925         sv_utf8_upgrade(lsv);
1926         sv_pos_u2b(lsv, &lvoff, &lvlen);
1927         sv_insert(lsv, lvoff, lvlen, tmps, len);
1928         LvTARGLEN(sv) = sv_len_utf8(sv);
1929         SvUTF8_on(lsv);
1930     }
1931     else if (lsv && SvUTF8(lsv)) {
1932         const char *utf8;
1933         sv_pos_u2b(lsv, &lvoff, &lvlen);
1934         LvTARGLEN(sv) = len;
1935         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1936         sv_insert(lsv, lvoff, lvlen, utf8, len);
1937         Safefree(utf8);
1938     }
1939     else {
1940         sv_insert(lsv, lvoff, lvlen, tmps, len);
1941         LvTARGLEN(sv) = len;
1942     }
1943
1944
1945     return 0;
1946 }
1947
1948 int
1949 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1950 {
1951     dVAR;
1952     PERL_UNUSED_ARG(sv);
1953     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1954     return 0;
1955 }
1956
1957 int
1958 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1959 {
1960     dVAR;
1961     PERL_UNUSED_ARG(sv);
1962     /* update taint status unless we're restoring at scope exit */
1963     if (PL_localizing != 2) {
1964         if (PL_tainted)
1965             mg->mg_len |= 1;
1966         else
1967             mg->mg_len &= ~1;
1968     }
1969     return 0;
1970 }
1971
1972 int
1973 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1974 {
1975     SV * const lsv = LvTARG(sv);
1976     PERL_UNUSED_ARG(mg);
1977
1978     if (lsv)
1979         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1980     else
1981         SvOK_off(sv);
1982
1983     return 0;
1984 }
1985
1986 int
1987 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1988 {
1989     PERL_UNUSED_ARG(mg);
1990     do_vecset(sv);      /* XXX slurp this routine */
1991     return 0;
1992 }
1993
1994 int
1995 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1996 {
1997     dVAR;
1998     SV *targ = NULL;
1999     if (LvTARGLEN(sv)) {
2000         if (mg->mg_obj) {
2001             SV * const ahv = LvTARG(sv);
2002             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2003             if (he)
2004                 targ = HeVAL(he);
2005         }
2006         else {
2007             AV* const av = (AV*)LvTARG(sv);
2008             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2009                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2010         }
2011         if (targ && (targ != &PL_sv_undef)) {
2012             /* somebody else defined it for us */
2013             SvREFCNT_dec(LvTARG(sv));
2014             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2015             LvTARGLEN(sv) = 0;
2016             SvREFCNT_dec(mg->mg_obj);
2017             mg->mg_obj = NULL;
2018             mg->mg_flags &= ~MGf_REFCOUNTED;
2019         }
2020     }
2021     else
2022         targ = LvTARG(sv);
2023     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2024     return 0;
2025 }
2026
2027 int
2028 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2029 {
2030     PERL_UNUSED_ARG(mg);
2031     if (LvTARGLEN(sv))
2032         vivify_defelem(sv);
2033     if (LvTARG(sv)) {
2034         sv_setsv(LvTARG(sv), sv);
2035         SvSETMAGIC(LvTARG(sv));
2036     }
2037     return 0;
2038 }
2039
2040 void
2041 Perl_vivify_defelem(pTHX_ SV *sv)
2042 {
2043     dVAR;
2044     MAGIC *mg;
2045     SV *value = NULL;
2046
2047     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2048         return;
2049     if (mg->mg_obj) {
2050         SV * const ahv = LvTARG(sv);
2051         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2052         if (he)
2053             value = HeVAL(he);
2054         if (!value || value == &PL_sv_undef)
2055             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2056     }
2057     else {
2058         AV* const av = (AV*)LvTARG(sv);
2059         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2060             LvTARG(sv) = NULL;  /* array can't be extended */
2061         else {
2062             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2063             if (!svp || (value = *svp) == &PL_sv_undef)
2064                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2065         }
2066     }
2067     SvREFCNT_inc_simple_void(value);
2068     SvREFCNT_dec(LvTARG(sv));
2069     LvTARG(sv) = value;
2070     LvTARGLEN(sv) = 0;
2071     SvREFCNT_dec(mg->mg_obj);
2072     mg->mg_obj = NULL;
2073     mg->mg_flags &= ~MGf_REFCOUNTED;
2074 }
2075
2076 int
2077 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2078 {
2079     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2080 }
2081
2082 int
2083 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2084 {
2085     PERL_UNUSED_CONTEXT;
2086     mg->mg_len = -1;
2087     SvSCREAM_off(sv);
2088     return 0;
2089 }
2090
2091 int
2092 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2093 {
2094     PERL_UNUSED_ARG(mg);
2095     sv_unmagic(sv, PERL_MAGIC_bm);
2096     SvVALID_off(sv);
2097     return 0;
2098 }
2099
2100 int
2101 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2102 {
2103     PERL_UNUSED_ARG(mg);
2104     sv_unmagic(sv, PERL_MAGIC_fm);
2105     SvCOMPILED_off(sv);
2106     return 0;
2107 }
2108
2109 int
2110 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2111 {
2112     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2113
2114     if (uf && uf->uf_set)
2115         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2116     return 0;
2117 }
2118
2119 int
2120 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2121 {
2122     PERL_UNUSED_ARG(mg);
2123     sv_unmagic(sv, PERL_MAGIC_qr);
2124     return 0;
2125 }
2126
2127 int
2128 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2129 {
2130     dVAR;
2131     regexp * const re = (regexp *)mg->mg_obj;
2132     PERL_UNUSED_ARG(sv);
2133
2134     ReREFCNT_dec(re);
2135     return 0;
2136 }
2137
2138 #ifdef USE_LOCALE_COLLATE
2139 int
2140 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2141 {
2142     /*
2143      * RenE<eacute> Descartes said "I think not."
2144      * and vanished with a faint plop.
2145      */
2146     PERL_UNUSED_CONTEXT;
2147     PERL_UNUSED_ARG(sv);
2148     if (mg->mg_ptr) {
2149         Safefree(mg->mg_ptr);
2150         mg->mg_ptr = NULL;
2151         mg->mg_len = -1;
2152     }
2153     return 0;
2154 }
2155 #endif /* USE_LOCALE_COLLATE */
2156
2157 /* Just clear the UTF-8 cache data. */
2158 int
2159 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2160 {
2161     PERL_UNUSED_CONTEXT;
2162     PERL_UNUSED_ARG(sv);
2163     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2164     mg->mg_ptr = NULL;
2165     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2166     return 0;
2167 }
2168
2169 int
2170 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2171 {
2172     dVAR;
2173     register const char *s;
2174     I32 i;
2175     STRLEN len;
2176     switch (*mg->mg_ptr) {
2177     case '\001':        /* ^A */
2178         sv_setsv(PL_bodytarget, sv);
2179         break;
2180     case '\003':        /* ^C */
2181         PL_minus_c = (bool)SvIV(sv);
2182         break;
2183
2184     case '\004':        /* ^D */
2185 #ifdef DEBUGGING
2186         s = SvPV_nolen_const(sv);
2187         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2188         DEBUG_x(dump_all());
2189 #else
2190         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2191 #endif
2192         break;
2193     case '\005':  /* ^E */
2194         if (*(mg->mg_ptr+1) == '\0') {
2195 #ifdef MACOS_TRADITIONAL
2196             gMacPerl_OSErr = SvIV(sv);
2197 #else
2198 #  ifdef VMS
2199             set_vaxc_errno(SvIV(sv));
2200 #  else
2201 #    ifdef WIN32
2202             SetLastError( SvIV(sv) );
2203 #    else
2204 #      ifdef OS2
2205             os2_setsyserrno(SvIV(sv));
2206 #      else
2207             /* will anyone ever use this? */
2208             SETERRNO(SvIV(sv), 4);
2209 #      endif
2210 #    endif
2211 #  endif
2212 #endif
2213         }
2214         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2215             if (PL_encoding)
2216                 SvREFCNT_dec(PL_encoding);
2217             if (SvOK(sv) || SvGMAGICAL(sv)) {
2218                 PL_encoding = newSVsv(sv);
2219             }
2220             else {
2221                 PL_encoding = NULL;
2222             }
2223         }
2224         break;
2225     case '\006':        /* ^F */
2226         PL_maxsysfd = SvIV(sv);
2227         break;
2228     case '\010':        /* ^H */
2229         PL_hints = SvIV(sv);
2230         break;
2231     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2232         Safefree(PL_inplace);
2233         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2234         break;
2235     case '\017':        /* ^O */
2236         if (*(mg->mg_ptr+1) == '\0') {
2237             Safefree(PL_osname);
2238             PL_osname = NULL;
2239             if (SvOK(sv)) {
2240                 TAINT_PROPER("assigning to $^O");
2241                 PL_osname = savesvpv(sv);
2242             }
2243         }
2244         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2245             PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2246             PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2247             PL_compiling.cop_hints_hash
2248                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2249                                          sv_2mortal(newSVpvs("open")), sv);
2250         }
2251         break;
2252     case '\020':        /* ^P */
2253         PL_perldb = SvIV(sv);
2254         if (PL_perldb && !PL_DBsingle)
2255             init_debugger();
2256         break;
2257     case '\024':        /* ^T */
2258 #ifdef BIG_TIME
2259         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2260 #else
2261         PL_basetime = (Time_t)SvIV(sv);
2262 #endif
2263         break;
2264     case '\025':        /* ^UTF8CACHE */
2265          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2266              PL_utf8cache = (signed char) sv_2iv(sv);
2267          }
2268          break;
2269     case '\027':        /* ^W & $^WARNING_BITS */
2270         if (*(mg->mg_ptr+1) == '\0') {
2271             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2272                 i = SvIV(sv);
2273                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2274                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2275             }
2276         }
2277         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2278             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2279                 if (!SvPOK(sv) && PL_localizing) {
2280                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2281                     PL_compiling.cop_warnings = pWARN_NONE;
2282                     break;
2283                 }
2284                 {
2285                     STRLEN len, i;
2286                     int accumulate = 0 ;
2287                     int any_fatals = 0 ;
2288                     const char * const ptr = SvPV_const(sv, len) ;
2289                     for (i = 0 ; i < len ; ++i) {
2290                         accumulate |= ptr[i] ;
2291                         any_fatals |= (ptr[i] & 0xAA) ;
2292                     }
2293                     if (!accumulate)
2294                         PL_compiling.cop_warnings = pWARN_NONE;
2295                     /* Yuck. I can't see how to abstract this:  */
2296                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2297                                        WARN_ALL) && !any_fatals) {
2298                         PL_compiling.cop_warnings = pWARN_ALL;
2299                         PL_dowarn |= G_WARN_ONCE ;
2300                     }
2301                     else {
2302                         STRLEN len;
2303                         const char *const p = SvPV_const(sv, len);
2304
2305                         PL_compiling.cop_warnings
2306                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2307                                                          p, len);
2308
2309                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2310                             PL_dowarn |= G_WARN_ONCE ;
2311                     }
2312
2313                 }
2314             }
2315         }
2316         break;
2317     case '.':
2318         if (PL_localizing) {
2319             if (PL_localizing == 1)
2320                 SAVESPTR(PL_last_in_gv);
2321         }
2322         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2323             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2324         break;
2325     case '^':
2326         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2327         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2328         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2329         break;
2330     case '~':
2331         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2332         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2333         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2334         break;
2335     case '=':
2336         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2337         break;
2338     case '-':
2339         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2340         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2341             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2342         break;
2343     case '%':
2344         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2345         break;
2346     case '|':
2347         {
2348             IO * const io = GvIOp(PL_defoutgv);
2349             if(!io)
2350               break;
2351             if ((SvIV(sv)) == 0)
2352                 IoFLAGS(io) &= ~IOf_FLUSH;
2353             else {
2354                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2355                     PerlIO *ofp = IoOFP(io);
2356                     if (ofp)
2357                         (void)PerlIO_flush(ofp);
2358                     IoFLAGS(io) |= IOf_FLUSH;
2359                 }
2360             }
2361         }
2362         break;
2363     case '/':
2364         SvREFCNT_dec(PL_rs);
2365         PL_rs = newSVsv(sv);
2366         break;
2367     case '\\':
2368         if (PL_ors_sv)
2369             SvREFCNT_dec(PL_ors_sv);
2370         if (SvOK(sv) || SvGMAGICAL(sv)) {
2371             PL_ors_sv = newSVsv(sv);
2372         }
2373         else {
2374             PL_ors_sv = NULL;
2375         }
2376         break;
2377     case ',':
2378         if (PL_ofs_sv)
2379             SvREFCNT_dec(PL_ofs_sv);
2380         if (SvOK(sv) || SvGMAGICAL(sv)) {
2381             PL_ofs_sv = newSVsv(sv);
2382         }
2383         else {
2384             PL_ofs_sv = NULL;
2385         }
2386         break;
2387     case '[':
2388         CopARYBASE_set(&PL_compiling, SvIV(sv));
2389         break;
2390     case '?':
2391 #ifdef COMPLEX_STATUS
2392         if (PL_localizing == 2) {
2393             PL_statusvalue = LvTARGOFF(sv);
2394             PL_statusvalue_vms = LvTARGLEN(sv);
2395         }
2396         else
2397 #endif
2398 #ifdef VMSISH_STATUS
2399         if (VMSISH_STATUS)
2400             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2401         else
2402 #endif
2403             STATUS_UNIX_EXIT_SET(SvIV(sv));
2404         break;
2405     case '!':
2406         {
2407 #ifdef VMS
2408 #   define PERL_VMS_BANG vaxc$errno
2409 #else
2410 #   define PERL_VMS_BANG 0
2411 #endif
2412         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2413                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2414         }
2415         break;
2416     case '<':
2417         PL_uid = SvIV(sv);
2418         if (PL_delaymagic) {
2419             PL_delaymagic |= DM_RUID;
2420             break;                              /* don't do magic till later */
2421         }
2422 #ifdef HAS_SETRUID
2423         (void)setruid((Uid_t)PL_uid);
2424 #else
2425 #ifdef HAS_SETREUID
2426         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2427 #else
2428 #ifdef HAS_SETRESUID
2429       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2430 #else
2431         if (PL_uid == PL_euid) {                /* special case $< = $> */
2432 #ifdef PERL_DARWIN
2433             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2434             if (PL_uid != 0 && PerlProc_getuid() == 0)
2435                 (void)PerlProc_setuid(0);
2436 #endif
2437             (void)PerlProc_setuid(PL_uid);
2438         } else {
2439             PL_uid = PerlProc_getuid();
2440             Perl_croak(aTHX_ "setruid() not implemented");
2441         }
2442 #endif
2443 #endif
2444 #endif
2445         PL_uid = PerlProc_getuid();
2446         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2447         break;
2448     case '>':
2449         PL_euid = SvIV(sv);
2450         if (PL_delaymagic) {
2451             PL_delaymagic |= DM_EUID;
2452             break;                              /* don't do magic till later */
2453         }
2454 #ifdef HAS_SETEUID
2455         (void)seteuid((Uid_t)PL_euid);
2456 #else
2457 #ifdef HAS_SETREUID
2458         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2459 #else
2460 #ifdef HAS_SETRESUID
2461         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2462 #else
2463         if (PL_euid == PL_uid)          /* special case $> = $< */
2464             PerlProc_setuid(PL_euid);
2465         else {
2466             PL_euid = PerlProc_geteuid();
2467             Perl_croak(aTHX_ "seteuid() not implemented");
2468         }
2469 #endif
2470 #endif
2471 #endif
2472         PL_euid = PerlProc_geteuid();
2473         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2474         break;
2475     case '(':
2476         PL_gid = SvIV(sv);
2477         if (PL_delaymagic) {
2478             PL_delaymagic |= DM_RGID;
2479             break;                              /* don't do magic till later */
2480         }
2481 #ifdef HAS_SETRGID
2482         (void)setrgid((Gid_t)PL_gid);
2483 #else
2484 #ifdef HAS_SETREGID
2485         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2486 #else
2487 #ifdef HAS_SETRESGID
2488       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2489 #else
2490         if (PL_gid == PL_egid)                  /* special case $( = $) */
2491             (void)PerlProc_setgid(PL_gid);
2492         else {
2493             PL_gid = PerlProc_getgid();
2494             Perl_croak(aTHX_ "setrgid() not implemented");
2495         }
2496 #endif
2497 #endif
2498 #endif
2499         PL_gid = PerlProc_getgid();
2500         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2501         break;
2502     case ')':
2503 #ifdef HAS_SETGROUPS
2504         {
2505             const char *p = SvPV_const(sv, len);
2506             Groups_t *gary = NULL;
2507
2508             while (isSPACE(*p))
2509                 ++p;
2510             PL_egid = Atol(p);
2511             for (i = 0; i < NGROUPS; ++i) {
2512                 while (*p && !isSPACE(*p))
2513                     ++p;
2514                 while (isSPACE(*p))
2515                     ++p;
2516                 if (!*p)
2517                     break;
2518                 if(!gary)
2519                     Newx(gary, i + 1, Groups_t);
2520                 else
2521                     Renew(gary, i + 1, Groups_t);
2522                 gary[i] = Atol(p);
2523             }
2524             if (i)
2525                 (void)setgroups(i, gary);
2526             if (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             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     assert(mg->mg_len == HEf_SVKEY);
2911
2912     PERL_UNUSED_ARG(sv);
2913
2914     PL_hints |= HINT_LOCALIZE_HH;
2915     PL_compiling.cop_hints_hash
2916         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2917                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
2918     return 0;
2919 }
2920
2921 /*
2922  * Local variables:
2923  * c-indentation-style: bsd
2924  * c-basic-offset: 4
2925  * indent-tabs-mode: t
2926  * End:
2927  *
2928  * ex: set ts=8 sts=4 sw=4 noet:
2929  */