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     SvVALID_off(sv);
2121     return 0;
2122 }
2123
2124 int
2125 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2126 {
2127     PERL_UNUSED_ARG(mg);
2128     sv_unmagic(sv, PERL_MAGIC_fm);
2129     SvCOMPILED_off(sv);
2130     return 0;
2131 }
2132
2133 int
2134 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2135 {
2136     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2137
2138     if (uf && uf->uf_set)
2139         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2140     return 0;
2141 }
2142
2143 int
2144 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2145 {
2146     PERL_UNUSED_ARG(mg);
2147     sv_unmagic(sv, PERL_MAGIC_qr);
2148     return 0;
2149 }
2150
2151 int
2152 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2153 {
2154     dVAR;
2155     regexp * const re = (regexp *)mg->mg_obj;
2156     PERL_UNUSED_ARG(sv);
2157
2158     ReREFCNT_dec(re);
2159     return 0;
2160 }
2161
2162 #ifdef USE_LOCALE_COLLATE
2163 int
2164 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2165 {
2166     /*
2167      * RenE<eacute> Descartes said "I think not."
2168      * and vanished with a faint plop.
2169      */
2170     PERL_UNUSED_CONTEXT;
2171     PERL_UNUSED_ARG(sv);
2172     if (mg->mg_ptr) {
2173         Safefree(mg->mg_ptr);
2174         mg->mg_ptr = NULL;
2175         mg->mg_len = -1;
2176     }
2177     return 0;
2178 }
2179 #endif /* USE_LOCALE_COLLATE */
2180
2181 /* Just clear the UTF-8 cache data. */
2182 int
2183 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2184 {
2185     PERL_UNUSED_CONTEXT;
2186     PERL_UNUSED_ARG(sv);
2187     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2188     mg->mg_ptr = NULL;
2189     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2190     return 0;
2191 }
2192
2193 int
2194 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2195 {
2196     dVAR;
2197     register const char *s;
2198     I32 i;
2199     STRLEN len;
2200     switch (*mg->mg_ptr) {
2201     case '\001':        /* ^A */
2202         sv_setsv(PL_bodytarget, sv);
2203         break;
2204     case '\003':        /* ^C */
2205         PL_minus_c = (bool)SvIV(sv);
2206         break;
2207
2208     case '\004':        /* ^D */
2209 #ifdef DEBUGGING
2210         s = SvPV_nolen_const(sv);
2211         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2212         DEBUG_x(dump_all());
2213 #else
2214         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2215 #endif
2216         break;
2217     case '\005':  /* ^E */
2218         if (*(mg->mg_ptr+1) == '\0') {
2219 #ifdef MACOS_TRADITIONAL
2220             gMacPerl_OSErr = SvIV(sv);
2221 #else
2222 #  ifdef VMS
2223             set_vaxc_errno(SvIV(sv));
2224 #  else
2225 #    ifdef WIN32
2226             SetLastError( SvIV(sv) );
2227 #    else
2228 #      ifdef OS2
2229             os2_setsyserrno(SvIV(sv));
2230 #      else
2231             /* will anyone ever use this? */
2232             SETERRNO(SvIV(sv), 4);
2233 #      endif
2234 #    endif
2235 #  endif
2236 #endif
2237         }
2238         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2239             if (PL_encoding)
2240                 SvREFCNT_dec(PL_encoding);
2241             if (SvOK(sv) || SvGMAGICAL(sv)) {
2242                 PL_encoding = newSVsv(sv);
2243             }
2244             else {
2245                 PL_encoding = NULL;
2246             }
2247         }
2248         break;
2249     case '\006':        /* ^F */
2250         PL_maxsysfd = SvIV(sv);
2251         break;
2252     case '\010':        /* ^H */
2253         PL_hints = SvIV(sv);
2254         break;
2255     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2256         Safefree(PL_inplace);
2257         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2258         break;
2259     case '\017':        /* ^O */
2260         if (*(mg->mg_ptr+1) == '\0') {
2261             Safefree(PL_osname);
2262             PL_osname = NULL;
2263             if (SvOK(sv)) {
2264                 TAINT_PROPER("assigning to $^O");
2265                 PL_osname = savesvpv(sv);
2266             }
2267         }
2268         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2269             PL_compiling.cop_hints |= HINT_LEXICAL_IO;
2270             PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
2271             PL_compiling.cop_hints_hash
2272                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2273                                          sv_2mortal(newSVpvs("open")), sv);
2274         }
2275         break;
2276     case '\020':        /* ^P */
2277         PL_perldb = SvIV(sv);
2278         if (PL_perldb && !PL_DBsingle)
2279             init_debugger();
2280         break;
2281     case '\024':        /* ^T */
2282 #ifdef BIG_TIME
2283         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2284 #else
2285         PL_basetime = (Time_t)SvIV(sv);
2286 #endif
2287         break;
2288     case '\025':        /* ^UTF8CACHE */
2289          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2290              PL_utf8cache = (signed char) sv_2iv(sv);
2291          }
2292          break;
2293     case '\027':        /* ^W & $^WARNING_BITS */
2294         if (*(mg->mg_ptr+1) == '\0') {
2295             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2296                 i = SvIV(sv);
2297                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2298                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2299             }
2300         }
2301         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2302             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2303                 if (!SvPOK(sv) && PL_localizing) {
2304                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2305                     PL_compiling.cop_warnings = pWARN_NONE;
2306                     break;
2307                 }
2308                 {
2309                     STRLEN len, i;
2310                     int accumulate = 0 ;
2311                     int any_fatals = 0 ;
2312                     const char * const ptr = SvPV_const(sv, len) ;
2313                     for (i = 0 ; i < len ; ++i) {
2314                         accumulate |= ptr[i] ;
2315                         any_fatals |= (ptr[i] & 0xAA) ;
2316                     }
2317                     if (!accumulate) {
2318                         if (!specialWARN(PL_compiling.cop_warnings))
2319                             PerlMemShared_free(PL_compiling.cop_warnings);
2320                         PL_compiling.cop_warnings = pWARN_NONE;
2321                     }
2322                     /* Yuck. I can't see how to abstract this:  */
2323                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2324                                        WARN_ALL) && !any_fatals) {
2325                         if (!specialWARN(PL_compiling.cop_warnings))
2326                             PerlMemShared_free(PL_compiling.cop_warnings);
2327                         PL_compiling.cop_warnings = pWARN_ALL;
2328                         PL_dowarn |= G_WARN_ONCE ;
2329                     }
2330                     else {
2331                         STRLEN len;
2332                         const char *const p = SvPV_const(sv, len);
2333
2334                         PL_compiling.cop_warnings
2335                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2336                                                          p, len);
2337
2338                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2339                             PL_dowarn |= G_WARN_ONCE ;
2340                     }
2341
2342                 }
2343             }
2344         }
2345         break;
2346     case '.':
2347         if (PL_localizing) {
2348             if (PL_localizing == 1)
2349                 SAVESPTR(PL_last_in_gv);
2350         }
2351         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2352             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2353         break;
2354     case '^':
2355         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2356         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2357         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2358         break;
2359     case '~':
2360         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2361         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2362         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2363         break;
2364     case '=':
2365         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2366         break;
2367     case '-':
2368         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2369         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2370             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2371         break;
2372     case '%':
2373         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2374         break;
2375     case '|':
2376         {
2377             IO * const io = GvIOp(PL_defoutgv);
2378             if(!io)
2379               break;
2380             if ((SvIV(sv)) == 0)
2381                 IoFLAGS(io) &= ~IOf_FLUSH;
2382             else {
2383                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2384                     PerlIO *ofp = IoOFP(io);
2385                     if (ofp)
2386                         (void)PerlIO_flush(ofp);
2387                     IoFLAGS(io) |= IOf_FLUSH;
2388                 }
2389             }
2390         }
2391         break;
2392     case '/':
2393         SvREFCNT_dec(PL_rs);
2394         PL_rs = newSVsv(sv);
2395         break;
2396     case '\\':
2397         if (PL_ors_sv)
2398             SvREFCNT_dec(PL_ors_sv);
2399         if (SvOK(sv) || SvGMAGICAL(sv)) {
2400             PL_ors_sv = newSVsv(sv);
2401         }
2402         else {
2403             PL_ors_sv = NULL;
2404         }
2405         break;
2406     case ',':
2407         if (PL_ofs_sv)
2408             SvREFCNT_dec(PL_ofs_sv);
2409         if (SvOK(sv) || SvGMAGICAL(sv)) {
2410             PL_ofs_sv = newSVsv(sv);
2411         }
2412         else {
2413             PL_ofs_sv = NULL;
2414         }
2415         break;
2416     case '[':
2417         CopARYBASE_set(&PL_compiling, SvIV(sv));
2418         break;
2419     case '?':
2420 #ifdef COMPLEX_STATUS
2421         if (PL_localizing == 2) {
2422             PL_statusvalue = LvTARGOFF(sv);
2423             PL_statusvalue_vms = LvTARGLEN(sv);
2424         }
2425         else
2426 #endif
2427 #ifdef VMSISH_STATUS
2428         if (VMSISH_STATUS)
2429             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2430         else
2431 #endif
2432             STATUS_UNIX_EXIT_SET(SvIV(sv));
2433         break;
2434     case '!':
2435         {
2436 #ifdef VMS
2437 #   define PERL_VMS_BANG vaxc$errno
2438 #else
2439 #   define PERL_VMS_BANG 0
2440 #endif
2441         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2442                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2443         }
2444         break;
2445     case '<':
2446         PL_uid = SvIV(sv);
2447         if (PL_delaymagic) {
2448             PL_delaymagic |= DM_RUID;
2449             break;                              /* don't do magic till later */
2450         }
2451 #ifdef HAS_SETRUID
2452         (void)setruid((Uid_t)PL_uid);
2453 #else
2454 #ifdef HAS_SETREUID
2455         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2456 #else
2457 #ifdef HAS_SETRESUID
2458       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2459 #else
2460         if (PL_uid == PL_euid) {                /* special case $< = $> */
2461 #ifdef PERL_DARWIN
2462             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2463             if (PL_uid != 0 && PerlProc_getuid() == 0)
2464                 (void)PerlProc_setuid(0);
2465 #endif
2466             (void)PerlProc_setuid(PL_uid);
2467         } else {
2468             PL_uid = PerlProc_getuid();
2469             Perl_croak(aTHX_ "setruid() not implemented");
2470         }
2471 #endif
2472 #endif
2473 #endif
2474         PL_uid = PerlProc_getuid();
2475         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2476         break;
2477     case '>':
2478         PL_euid = SvIV(sv);
2479         if (PL_delaymagic) {
2480             PL_delaymagic |= DM_EUID;
2481             break;                              /* don't do magic till later */
2482         }
2483 #ifdef HAS_SETEUID
2484         (void)seteuid((Uid_t)PL_euid);
2485 #else
2486 #ifdef HAS_SETREUID
2487         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2488 #else
2489 #ifdef HAS_SETRESUID
2490         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2491 #else
2492         if (PL_euid == PL_uid)          /* special case $> = $< */
2493             PerlProc_setuid(PL_euid);
2494         else {
2495             PL_euid = PerlProc_geteuid();
2496             Perl_croak(aTHX_ "seteuid() not implemented");
2497         }
2498 #endif
2499 #endif
2500 #endif
2501         PL_euid = PerlProc_geteuid();
2502         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2503         break;
2504     case '(':
2505         PL_gid = SvIV(sv);
2506         if (PL_delaymagic) {
2507             PL_delaymagic |= DM_RGID;
2508             break;                              /* don't do magic till later */
2509         }
2510 #ifdef HAS_SETRGID
2511         (void)setrgid((Gid_t)PL_gid);
2512 #else
2513 #ifdef HAS_SETREGID
2514         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2515 #else
2516 #ifdef HAS_SETRESGID
2517       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2518 #else
2519         if (PL_gid == PL_egid)                  /* special case $( = $) */
2520             (void)PerlProc_setgid(PL_gid);
2521         else {
2522             PL_gid = PerlProc_getgid();
2523             Perl_croak(aTHX_ "setrgid() not implemented");
2524         }
2525 #endif
2526 #endif
2527 #endif
2528         PL_gid = PerlProc_getgid();
2529         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2530         break;
2531     case ')':
2532 #ifdef HAS_SETGROUPS
2533         {
2534             const char *p = SvPV_const(sv, len);
2535             Groups_t *gary = NULL;
2536
2537             while (isSPACE(*p))
2538                 ++p;
2539             PL_egid = Atol(p);
2540             for (i = 0; i < NGROUPS; ++i) {
2541                 while (*p && !isSPACE(*p))
2542                     ++p;
2543                 while (isSPACE(*p))
2544                     ++p;
2545                 if (!*p)
2546                     break;
2547                 if(!gary)
2548                     Newx(gary, i + 1, Groups_t);
2549                 else
2550                     Renew(gary, i + 1, Groups_t);
2551                 gary[i] = Atol(p);
2552             }
2553             if (i)
2554                 (void)setgroups(i, gary);
2555             Safefree(gary);
2556         }
2557 #else  /* HAS_SETGROUPS */
2558         PL_egid = SvIV(sv);
2559 #endif /* HAS_SETGROUPS */
2560         if (PL_delaymagic) {
2561             PL_delaymagic |= DM_EGID;
2562             break;                              /* don't do magic till later */
2563         }
2564 #ifdef HAS_SETEGID
2565         (void)setegid((Gid_t)PL_egid);
2566 #else
2567 #ifdef HAS_SETREGID
2568         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2569 #else
2570 #ifdef HAS_SETRESGID
2571         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2572 #else
2573         if (PL_egid == PL_gid)                  /* special case $) = $( */
2574             (void)PerlProc_setgid(PL_egid);
2575         else {
2576             PL_egid = PerlProc_getegid();
2577             Perl_croak(aTHX_ "setegid() not implemented");
2578         }
2579 #endif
2580 #endif
2581 #endif
2582         PL_egid = PerlProc_getegid();
2583         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2584         break;
2585     case ':':
2586         PL_chopset = SvPV_force(sv,len);
2587         break;
2588 #ifndef MACOS_TRADITIONAL
2589     case '0':
2590         LOCK_DOLLARZERO_MUTEX;
2591 #ifdef HAS_SETPROCTITLE
2592         /* The BSDs don't show the argv[] in ps(1) output, they
2593          * show a string from the process struct and provide
2594          * the setproctitle() routine to manipulate that. */
2595         if (PL_origalen != 1) {
2596             s = SvPV_const(sv, len);
2597 #   if __FreeBSD_version > 410001
2598             /* The leading "-" removes the "perl: " prefix,
2599              * but not the "(perl) suffix from the ps(1)
2600              * output, because that's what ps(1) shows if the
2601              * argv[] is modified. */
2602             setproctitle("-%s", s);
2603 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2604             /* This doesn't really work if you assume that
2605              * $0 = 'foobar'; will wipe out 'perl' from the $0
2606              * because in ps(1) output the result will be like
2607              * sprintf("perl: %s (perl)", s)
2608              * I guess this is a security feature:
2609              * one (a user process) cannot get rid of the original name.
2610              * --jhi */
2611             setproctitle("%s", s);
2612 #   endif
2613         }
2614 #endif
2615 #if 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 #endif
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                 Copy(s, PL_origargv[0], len, char);
2634                 PL_origargv[0][len] = 0;
2635                 memset(PL_origargv[0] + len + 1,
2636                        /* Is the space counterintuitive?  Yes.
2637                         * (You were expecting \0?)
2638                         * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2639                         * --jhi */
2640                        (int)' ',
2641                        PL_origalen - len - 1);
2642             }
2643             PL_origargv[0][PL_origalen-1] = 0;
2644             for (i = 1; i < PL_origargc; i++)
2645                 PL_origargv[i] = 0;
2646         }
2647         UNLOCK_DOLLARZERO_MUTEX;
2648         break;
2649 #endif
2650     }
2651     return 0;
2652 }
2653
2654 I32
2655 Perl_whichsig(pTHX_ const char *sig)
2656 {
2657     register char* const* sigv;
2658     PERL_UNUSED_CONTEXT;
2659
2660     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2661         if (strEQ(sig,*sigv))
2662             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2663 #ifdef SIGCLD
2664     if (strEQ(sig,"CHLD"))
2665         return SIGCLD;
2666 #endif
2667 #ifdef SIGCHLD
2668     if (strEQ(sig,"CLD"))
2669         return SIGCHLD;
2670 #endif
2671     return -1;
2672 }
2673
2674 Signal_t
2675 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2676 Perl_sighandler(int sig, ...)
2677 #else
2678 Perl_sighandler(int sig)
2679 #endif
2680 {
2681 #ifdef PERL_GET_SIG_CONTEXT
2682     dTHXa(PERL_GET_SIG_CONTEXT);
2683 #else
2684     dTHX;
2685 #endif
2686     dSP;
2687     GV *gv = NULL;
2688     SV *sv = NULL;
2689     SV * const tSv = PL_Sv;
2690     CV *cv = NULL;
2691     OP *myop = PL_op;
2692     U32 flags = 0;
2693     XPV * const tXpv = PL_Xpv;
2694
2695     if (PL_savestack_ix + 15 <= PL_savestack_max)
2696         flags |= 1;
2697     if (PL_markstack_ptr < PL_markstack_max - 2)
2698         flags |= 4;
2699     if (PL_scopestack_ix < PL_scopestack_max - 3)
2700         flags |= 16;
2701
2702     if (!PL_psig_ptr[sig]) {
2703                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2704                                  PL_sig_name[sig]);
2705                 exit(sig);
2706         }
2707
2708     /* Max number of items pushed there is 3*n or 4. We cannot fix
2709        infinity, so we fix 4 (in fact 5): */
2710     if (flags & 1) {
2711         PL_savestack_ix += 5;           /* Protect save in progress. */
2712         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2713     }
2714     if (flags & 4)
2715         PL_markstack_ptr++;             /* Protect mark. */
2716     if (flags & 16)
2717         PL_scopestack_ix += 1;
2718     /* sv_2cv is too complicated, try a simpler variant first: */
2719     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2720         || SvTYPE(cv) != SVt_PVCV) {
2721         HV *st;
2722         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2723     }
2724
2725     if (!cv || !CvROOT(cv)) {
2726         if (ckWARN(WARN_SIGNAL))
2727             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2728                 PL_sig_name[sig], (gv ? GvENAME(gv)
2729                                 : ((cv && CvGV(cv))
2730                                    ? GvENAME(CvGV(cv))
2731                                    : "__ANON__")));
2732         goto cleanup;
2733     }
2734
2735     if(PL_psig_name[sig]) {
2736         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2737         flags |= 64;
2738 #if !defined(PERL_IMPLICIT_CONTEXT)
2739         PL_sig_sv = sv;
2740 #endif
2741     } else {
2742         sv = sv_newmortal();
2743         sv_setpv(sv,PL_sig_name[sig]);
2744     }
2745
2746     PUSHSTACKi(PERLSI_SIGNAL);
2747     PUSHMARK(SP);
2748     PUSHs(sv);
2749 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2750     {
2751          struct sigaction oact;
2752
2753          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2754               siginfo_t *sip;
2755               va_list args;
2756
2757               va_start(args, sig);
2758               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2759               if (sip) {
2760                    HV *sih = newHV();
2761                    SV *rv  = newRV_noinc((SV*)sih);
2762                    /* The siginfo fields signo, code, errno, pid, uid,
2763                     * addr, status, and band are defined by POSIX/SUSv3. */
2764                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2765                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2766 #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. */
2767                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2768                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2769                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2770                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2771                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2772                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2773 #endif
2774                    EXTEND(SP, 2);
2775                    PUSHs((SV*)rv);
2776                    PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2777               }
2778
2779               va_end(args);
2780          }
2781     }
2782 #endif
2783     PUTBACK;
2784
2785     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2786
2787     POPSTACK;
2788     if (SvTRUE(ERRSV)) {
2789 #ifndef PERL_MICRO
2790 #ifdef HAS_SIGPROCMASK
2791         /* Handler "died", for example to get out of a restart-able read().
2792          * Before we re-do that on its behalf re-enable the signal which was
2793          * blocked by the system when we entered.
2794          */
2795         sigset_t set;
2796         sigemptyset(&set);
2797         sigaddset(&set,sig);
2798         sigprocmask(SIG_UNBLOCK, &set, NULL);
2799 #else
2800         /* Not clear if this will work */
2801         (void)rsignal(sig, SIG_IGN);
2802         (void)rsignal(sig, PL_csighandlerp);
2803 #endif
2804 #endif /* !PERL_MICRO */
2805         Perl_die(aTHX_ NULL);
2806     }
2807 cleanup:
2808     if (flags & 1)
2809         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2810     if (flags & 4)
2811         PL_markstack_ptr--;
2812     if (flags & 16)
2813         PL_scopestack_ix -= 1;
2814     if (flags & 64)
2815         SvREFCNT_dec(sv);
2816     PL_op = myop;                       /* Apparently not needed... */
2817
2818     PL_Sv = tSv;                        /* Restore global temporaries. */
2819     PL_Xpv = tXpv;
2820     return;
2821 }
2822
2823
2824 static void
2825 S_restore_magic(pTHX_ const void *p)
2826 {
2827     dVAR;
2828     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2829     SV* const sv = mgs->mgs_sv;
2830
2831     if (!sv)
2832         return;
2833
2834     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2835     {
2836 #ifdef PERL_OLD_COPY_ON_WRITE
2837         /* While magic was saved (and off) sv_setsv may well have seen
2838            this SV as a prime candidate for COW.  */
2839         if (SvIsCOW(sv))
2840             sv_force_normal_flags(sv, 0);
2841 #endif
2842
2843         if (mgs->mgs_flags)
2844             SvFLAGS(sv) |= mgs->mgs_flags;
2845         else
2846             mg_magical(sv);
2847         if (SvGMAGICAL(sv)) {
2848             /* downgrade public flags to private,
2849                and discard any other private flags */
2850
2851             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2852             if (pubflags) {
2853                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2854                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2855             }
2856         }
2857     }
2858
2859     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2860
2861     /* If we're still on top of the stack, pop us off.  (That condition
2862      * will be satisfied if restore_magic was called explicitly, but *not*
2863      * if it's being called via leave_scope.)
2864      * The reason for doing this is that otherwise, things like sv_2cv()
2865      * may leave alloc gunk on the savestack, and some code
2866      * (e.g. sighandler) doesn't expect that...
2867      */
2868     if (PL_savestack_ix == mgs->mgs_ss_ix)
2869     {
2870         I32 popval = SSPOPINT;
2871         assert(popval == SAVEt_DESTRUCTOR_X);
2872         PL_savestack_ix -= 2;
2873         popval = SSPOPINT;
2874         assert(popval == SAVEt_ALLOC);
2875         popval = SSPOPINT;
2876         PL_savestack_ix -= popval;
2877     }
2878
2879 }
2880
2881 static void
2882 S_unwind_handler_stack(pTHX_ const void *p)
2883 {
2884     dVAR;
2885     const U32 flags = *(const U32*)p;
2886
2887     if (flags & 1)
2888         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2889 #if !defined(PERL_IMPLICIT_CONTEXT)
2890     if (flags & 64)
2891         SvREFCNT_dec(PL_sig_sv);
2892 #endif
2893 }
2894
2895 /*
2896 =for apidoc magic_sethint
2897
2898 Triggered by a store to %^H, records the key/value pair to
2899 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
2900 anything that would need a deep copy.  Maybe we should warn if we find a
2901 reference.
2902
2903 =cut
2904 */
2905 int
2906 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2907 {
2908     dVAR;
2909     assert(mg->mg_len == HEf_SVKEY);
2910
2911     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
2912        an alternative leaf in there, with PL_compiling.cop_hints being used if
2913        it's NULL. If needed for threads, the alternative could lock a mutex,
2914        or take other more complex action.  */
2915
2916     /* Something changed in %^H, so it will need to be restored on scope exit.
2917        Doing this here saves a lot of doing it manually in perl code (and
2918        forgetting to do it, and consequent subtle errors.  */
2919     PL_hints |= HINT_LOCALIZE_HH;
2920     PL_compiling.cop_hints_hash
2921         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2922                                  (SV *)mg->mg_ptr, sv);
2923     return 0;
2924 }
2925
2926 /*
2927 =for apidoc magic_sethint
2928
2929 Triggered by a delete from %^H, records the key to
2930 C<PL_compiling.cop_hints_hash>.
2931
2932 =cut
2933 */
2934 int
2935 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2936 {
2937     dVAR;
2938     PERL_UNUSED_ARG(sv);
2939
2940     assert(mg->mg_len == HEf_SVKEY);
2941
2942     PERL_UNUSED_ARG(sv);
2943
2944     PL_hints |= HINT_LOCALIZE_HH;
2945     PL_compiling.cop_hints_hash
2946         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2947                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
2948     return 0;
2949 }
2950
2951 /*
2952  * Local variables:
2953  * c-indentation-style: bsd
2954  * c-basic-offset: 4
2955  * indent-tabs-mode: t
2956  * End:
2957  *
2958  * ex: set ts=8 sts=4 sw=4 noet:
2959  */