mg.c

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