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