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