mg.c

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