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