mg.c

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