mg.c

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