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