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