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 (isGV_with_GP(sv)) {
1901         /* We're actually already a typeglob, so don't need the stuff below.
1902          */
1903         return 0;
1904     }
1905     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1906     if (sv == (SV*)gv)
1907         return 0;
1908     if (GvGP(sv))
1909         gp_free((GV*)sv);
1910     GvGP(sv) = gp_ref(GvGP(gv));
1911     return 0;
1912 }
1913
1914 int
1915 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1916 {
1917     STRLEN len;
1918     SV * const lsv = LvTARG(sv);
1919     const char * const tmps = SvPV_const(lsv,len);
1920     I32 offs = LvTARGOFF(sv);
1921     I32 rem = LvTARGLEN(sv);
1922     PERL_UNUSED_ARG(mg);
1923
1924     if (SvUTF8(lsv))
1925         sv_pos_u2b(lsv, &offs, &rem);
1926     if (offs > (I32)len)
1927         offs = len;
1928     if (rem + offs > (I32)len)
1929         rem = len - offs;
1930     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1931     if (SvUTF8(lsv))
1932         SvUTF8_on(sv);
1933     return 0;
1934 }
1935
1936 int
1937 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1938 {
1939     dVAR;
1940     STRLEN len;
1941     const char * const tmps = SvPV_const(sv, len);
1942     SV * const lsv = LvTARG(sv);
1943     I32 lvoff = LvTARGOFF(sv);
1944     I32 lvlen = LvTARGLEN(sv);
1945     PERL_UNUSED_ARG(mg);
1946
1947     if (DO_UTF8(sv)) {
1948         sv_utf8_upgrade(lsv);
1949         sv_pos_u2b(lsv, &lvoff, &lvlen);
1950         sv_insert(lsv, lvoff, lvlen, tmps, len);
1951         LvTARGLEN(sv) = sv_len_utf8(sv);
1952         SvUTF8_on(lsv);
1953     }
1954     else if (lsv && SvUTF8(lsv)) {
1955         const char *utf8;
1956         sv_pos_u2b(lsv, &lvoff, &lvlen);
1957         LvTARGLEN(sv) = len;
1958         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1959         sv_insert(lsv, lvoff, lvlen, utf8, len);
1960         Safefree(utf8);
1961     }
1962     else {
1963         sv_insert(lsv, lvoff, lvlen, tmps, len);
1964         LvTARGLEN(sv) = len;
1965     }
1966
1967
1968     return 0;
1969 }
1970
1971 int
1972 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1973 {
1974     dVAR;
1975     PERL_UNUSED_ARG(sv);
1976     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1977     return 0;
1978 }
1979
1980 int
1981 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1982 {
1983     dVAR;
1984     PERL_UNUSED_ARG(sv);
1985     /* update taint status unless we're restoring at scope exit */
1986     if (PL_localizing != 2) {
1987         if (PL_tainted)
1988             mg->mg_len |= 1;
1989         else
1990             mg->mg_len &= ~1;
1991     }
1992     return 0;
1993 }
1994
1995 int
1996 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1997 {
1998     SV * const lsv = LvTARG(sv);
1999     PERL_UNUSED_ARG(mg);
2000
2001     if (lsv)
2002         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2003     else
2004         SvOK_off(sv);
2005
2006     return 0;
2007 }
2008
2009 int
2010 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2011 {
2012     PERL_UNUSED_ARG(mg);
2013     do_vecset(sv);      /* XXX slurp this routine */
2014     return 0;
2015 }
2016
2017 int
2018 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2019 {
2020     dVAR;
2021     SV *targ = NULL;
2022     if (LvTARGLEN(sv)) {
2023         if (mg->mg_obj) {
2024             SV * const ahv = LvTARG(sv);
2025             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2026             if (he)
2027                 targ = HeVAL(he);
2028         }
2029         else {
2030             AV* const av = (AV*)LvTARG(sv);
2031             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2032                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2033         }
2034         if (targ && (targ != &PL_sv_undef)) {
2035             /* somebody else defined it for us */
2036             SvREFCNT_dec(LvTARG(sv));
2037             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2038             LvTARGLEN(sv) = 0;
2039             SvREFCNT_dec(mg->mg_obj);
2040             mg->mg_obj = NULL;
2041             mg->mg_flags &= ~MGf_REFCOUNTED;
2042         }
2043     }
2044     else
2045         targ = LvTARG(sv);
2046     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2047     return 0;
2048 }
2049
2050 int
2051 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2052 {
2053     PERL_UNUSED_ARG(mg);
2054     if (LvTARGLEN(sv))
2055         vivify_defelem(sv);
2056     if (LvTARG(sv)) {
2057         sv_setsv(LvTARG(sv), sv);
2058         SvSETMAGIC(LvTARG(sv));
2059     }
2060     return 0;
2061 }
2062
2063 void
2064 Perl_vivify_defelem(pTHX_ SV *sv)
2065 {
2066     dVAR;
2067     MAGIC *mg;
2068     SV *value = NULL;
2069
2070     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2071         return;
2072     if (mg->mg_obj) {
2073         SV * const ahv = LvTARG(sv);
2074         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2075         if (he)
2076             value = HeVAL(he);
2077         if (!value || value == &PL_sv_undef)
2078             Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
2079     }
2080     else {
2081         AV* const av = (AV*)LvTARG(sv);
2082         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2083             LvTARG(sv) = NULL;  /* array can't be extended */
2084         else {
2085             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2086             if (!svp || (value = *svp) == &PL_sv_undef)
2087                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2088         }
2089     }
2090     SvREFCNT_inc_simple_void(value);
2091     SvREFCNT_dec(LvTARG(sv));
2092     LvTARG(sv) = value;
2093     LvTARGLEN(sv) = 0;
2094     SvREFCNT_dec(mg->mg_obj);
2095     mg->mg_obj = NULL;
2096     mg->mg_flags &= ~MGf_REFCOUNTED;
2097 }
2098
2099 int
2100 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2101 {
2102     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2103 }
2104
2105 int
2106 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2107 {
2108     PERL_UNUSED_CONTEXT;
2109     mg->mg_len = -1;
2110     SvSCREAM_off(sv);
2111     return 0;
2112 }
2113
2114 int
2115 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2116 {
2117     PERL_UNUSED_ARG(mg);
2118     sv_unmagic(sv, PERL_MAGIC_bm);
2119     SvTAIL_off(sv);
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 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2615         if (PL_origalen != 1) {
2616              union pstun un;
2617              s = SvPV_const(sv, len);
2618              un.pst_command = (char *)s;
2619              pstat(PSTAT_SETCMD, un, len, 0, 0);
2620         }
2621 #else
2622         if (PL_origalen > 1) {
2623             /* PL_origalen is set in perl_parse(). */
2624             s = SvPV_force(sv,len);
2625             if (len >= (STRLEN)PL_origalen-1) {
2626                 /* Longer than original, will be truncated. We assume that
2627                  * PL_origalen bytes are available. */
2628                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2629             }
2630             else {
2631                 /* Shorter than original, will be padded. */
2632 #ifdef PERL_DARWIN
2633                 /* Special case for Mac OS X: see [perl #38868] */
2634                 const int pad = 0;
2635 #else
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                 const int pad = ' ';
2641 #endif
2642                 Copy(s, PL_origargv[0], len, char);
2643                 PL_origargv[0][len] = 0;
2644                 memset(PL_origargv[0] + len + 1,
2645                        pad,  PL_origalen - len - 1);
2646             }
2647             PL_origargv[0][PL_origalen-1] = 0;
2648             for (i = 1; i < PL_origargc; i++)
2649                 PL_origargv[i] = 0;
2650         }
2651 #endif
2652         UNLOCK_DOLLARZERO_MUTEX;
2653         break;
2654 #endif
2655     }
2656     return 0;
2657 }
2658
2659 I32
2660 Perl_whichsig(pTHX_ const char *sig)
2661 {
2662     register char* const* sigv;
2663     PERL_UNUSED_CONTEXT;
2664
2665     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2666         if (strEQ(sig,*sigv))
2667             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2668 #ifdef SIGCLD
2669     if (strEQ(sig,"CHLD"))
2670         return SIGCLD;
2671 #endif
2672 #ifdef SIGCHLD
2673     if (strEQ(sig,"CLD"))
2674         return SIGCHLD;
2675 #endif
2676     return -1;
2677 }
2678
2679 Signal_t
2680 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2681 Perl_sighandler(int sig, ...)
2682 #else
2683 Perl_sighandler(int sig)
2684 #endif
2685 {
2686 #ifdef PERL_GET_SIG_CONTEXT
2687     dTHXa(PERL_GET_SIG_CONTEXT);
2688 #else
2689     dTHX;
2690 #endif
2691     dSP;
2692     GV *gv = NULL;
2693     SV *sv = NULL;
2694     SV * const tSv = PL_Sv;
2695     CV *cv = NULL;
2696     OP *myop = PL_op;
2697     U32 flags = 0;
2698     XPV * const tXpv = PL_Xpv;
2699
2700     if (PL_savestack_ix + 15 <= PL_savestack_max)
2701         flags |= 1;
2702     if (PL_markstack_ptr < PL_markstack_max - 2)
2703         flags |= 4;
2704     if (PL_scopestack_ix < PL_scopestack_max - 3)
2705         flags |= 16;
2706
2707     if (!PL_psig_ptr[sig]) {
2708                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2709                                  PL_sig_name[sig]);
2710                 exit(sig);
2711         }
2712
2713     /* Max number of items pushed there is 3*n or 4. We cannot fix
2714        infinity, so we fix 4 (in fact 5): */
2715     if (flags & 1) {
2716         PL_savestack_ix += 5;           /* Protect save in progress. */
2717         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2718     }
2719     if (flags & 4)
2720         PL_markstack_ptr++;             /* Protect mark. */
2721     if (flags & 16)
2722         PL_scopestack_ix += 1;
2723     /* sv_2cv is too complicated, try a simpler variant first: */
2724     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2725         || SvTYPE(cv) != SVt_PVCV) {
2726         HV *st;
2727         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2728     }
2729
2730     if (!cv || !CvROOT(cv)) {
2731         if (ckWARN(WARN_SIGNAL))
2732             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2733                 PL_sig_name[sig], (gv ? GvENAME(gv)
2734                                 : ((cv && CvGV(cv))
2735                                    ? GvENAME(CvGV(cv))
2736                                    : "__ANON__")));
2737         goto cleanup;
2738     }
2739
2740     if(PL_psig_name[sig]) {
2741         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2742         flags |= 64;
2743 #if !defined(PERL_IMPLICIT_CONTEXT)
2744         PL_sig_sv = sv;
2745 #endif
2746     } else {
2747         sv = sv_newmortal();
2748         sv_setpv(sv,PL_sig_name[sig]);
2749     }
2750
2751     PUSHSTACKi(PERLSI_SIGNAL);
2752     PUSHMARK(SP);
2753     PUSHs(sv);
2754 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2755     {
2756          struct sigaction oact;
2757
2758          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2759               siginfo_t *sip;
2760               va_list args;
2761
2762               va_start(args, sig);
2763               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2764               if (sip) {
2765                    HV *sih = newHV();
2766                    SV *rv  = newRV_noinc((SV*)sih);
2767                    /* The siginfo fields signo, code, errno, pid, uid,
2768                     * addr, status, and band are defined by POSIX/SUSv3. */
2769                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2770                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2771 #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. */
2772                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2773                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2774                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2775                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2776                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2777                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2778 #endif
2779                    EXTEND(SP, 2);
2780                    PUSHs((SV*)rv);
2781                    PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2782               }
2783
2784               va_end(args);
2785          }
2786     }
2787 #endif
2788     PUTBACK;
2789
2790     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2791
2792     POPSTACK;
2793     if (SvTRUE(ERRSV)) {
2794 #ifndef PERL_MICRO
2795 #ifdef HAS_SIGPROCMASK
2796         /* Handler "died", for example to get out of a restart-able read().
2797          * Before we re-do that on its behalf re-enable the signal which was
2798          * blocked by the system when we entered.
2799          */
2800         sigset_t set;
2801         sigemptyset(&set);
2802         sigaddset(&set,sig);
2803         sigprocmask(SIG_UNBLOCK, &set, NULL);
2804 #else
2805         /* Not clear if this will work */
2806         (void)rsignal(sig, SIG_IGN);
2807         (void)rsignal(sig, PL_csighandlerp);
2808 #endif
2809 #endif /* !PERL_MICRO */
2810         Perl_die(aTHX_ NULL);
2811     }
2812 cleanup:
2813     if (flags & 1)
2814         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2815     if (flags & 4)
2816         PL_markstack_ptr--;
2817     if (flags & 16)
2818         PL_scopestack_ix -= 1;
2819     if (flags & 64)
2820         SvREFCNT_dec(sv);
2821     PL_op = myop;                       /* Apparently not needed... */
2822
2823     PL_Sv = tSv;                        /* Restore global temporaries. */
2824     PL_Xpv = tXpv;
2825     return;
2826 }
2827
2828
2829 static void
2830 S_restore_magic(pTHX_ const void *p)
2831 {
2832     dVAR;
2833     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2834     SV* const sv = mgs->mgs_sv;
2835
2836     if (!sv)
2837         return;
2838
2839     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2840     {
2841 #ifdef PERL_OLD_COPY_ON_WRITE
2842         /* While magic was saved (and off) sv_setsv may well have seen
2843            this SV as a prime candidate for COW.  */
2844         if (SvIsCOW(sv))
2845             sv_force_normal_flags(sv, 0);
2846 #endif
2847
2848         if (mgs->mgs_flags)
2849             SvFLAGS(sv) |= mgs->mgs_flags;
2850         else
2851             mg_magical(sv);
2852         if (SvGMAGICAL(sv)) {
2853             /* downgrade public flags to private,
2854                and discard any other private flags */
2855
2856             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2857             if (pubflags) {
2858                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2859                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2860             }
2861         }
2862     }
2863
2864     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2865
2866     /* If we're still on top of the stack, pop us off.  (That condition
2867      * will be satisfied if restore_magic was called explicitly, but *not*
2868      * if it's being called via leave_scope.)
2869      * The reason for doing this is that otherwise, things like sv_2cv()
2870      * may leave alloc gunk on the savestack, and some code
2871      * (e.g. sighandler) doesn't expect that...
2872      */
2873     if (PL_savestack_ix == mgs->mgs_ss_ix)
2874     {
2875         I32 popval = SSPOPINT;
2876         assert(popval == SAVEt_DESTRUCTOR_X);
2877         PL_savestack_ix -= 2;
2878         popval = SSPOPINT;
2879         assert(popval == SAVEt_ALLOC);
2880         popval = SSPOPINT;
2881         PL_savestack_ix -= popval;
2882     }
2883
2884 }
2885
2886 static void
2887 S_unwind_handler_stack(pTHX_ const void *p)
2888 {
2889     dVAR;
2890     const U32 flags = *(const U32*)p;
2891
2892     if (flags & 1)
2893         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2894 #if !defined(PERL_IMPLICIT_CONTEXT)
2895     if (flags & 64)
2896         SvREFCNT_dec(PL_sig_sv);
2897 #endif
2898 }
2899
2900 /*
2901 =for apidoc magic_sethint
2902
2903 Triggered by a store to %^H, records the key/value pair to
2904 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
2905 anything that would need a deep copy.  Maybe we should warn if we find a
2906 reference.
2907
2908 =cut
2909 */
2910 int
2911 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2912 {
2913     dVAR;
2914     assert(mg->mg_len == HEf_SVKEY);
2915
2916     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
2917        an alternative leaf in there, with PL_compiling.cop_hints being used if
2918        it's NULL. If needed for threads, the alternative could lock a mutex,
2919        or take other more complex action.  */
2920
2921     /* Something changed in %^H, so it will need to be restored on scope exit.
2922        Doing this here saves a lot of doing it manually in perl code (and
2923        forgetting to do it, and consequent subtle errors.  */
2924     PL_hints |= HINT_LOCALIZE_HH;
2925     PL_compiling.cop_hints_hash
2926         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2927                                  (SV *)mg->mg_ptr, sv);
2928     return 0;
2929 }
2930
2931 /*
2932 =for apidoc magic_sethint
2933
2934 Triggered by a delete from %^H, records the key to
2935 C<PL_compiling.cop_hints_hash>.
2936
2937 =cut
2938 */
2939 int
2940 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2941 {
2942     dVAR;
2943     PERL_UNUSED_ARG(sv);
2944
2945     assert(mg->mg_len == HEf_SVKEY);
2946
2947     PERL_UNUSED_ARG(sv);
2948
2949     PL_hints |= HINT_LOCALIZE_HH;
2950     PL_compiling.cop_hints_hash
2951         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2952                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
2953     return 0;
2954 }
2955
2956 /*
2957  * Local variables:
2958  * c-indentation-style: bsd
2959  * c-basic-offset: 4
2960  * indent-tabs-mode: t
2961  * End:
2962  *
2963  * ex: set ts=8 sts=4 sw=4 noet:
2964  */