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