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_setamagic(pTHX_ SV *sv, MAGIC *mg)
1557 {
1558     dVAR;
1559     PERL_UNUSED_ARG(sv);
1560     PERL_UNUSED_ARG(mg);
1561     PL_amagic_generation++;
1562
1563     return 0;
1564 }
1565
1566 int
1567 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1568 {
1569     HV * const hv = (HV*)LvTARG(sv);
1570     I32 i = 0;
1571     PERL_UNUSED_ARG(mg);
1572
1573     if (hv) {
1574          (void) hv_iterinit(hv);
1575          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1576              i = HvKEYS(hv);
1577          else {
1578              while (hv_iternext(hv))
1579                  i++;
1580          }
1581     }
1582
1583     sv_setiv(sv, (IV)i);
1584     return 0;
1585 }
1586
1587 int
1588 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1589 {
1590     PERL_UNUSED_ARG(mg);
1591     if (LvTARG(sv)) {
1592         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1593     }
1594     return 0;
1595 }
1596
1597 /* caller is responsible for stack switching/cleanup */
1598 STATIC int
1599 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1600 {
1601     dVAR;
1602     dSP;
1603
1604     PUSHMARK(SP);
1605     EXTEND(SP, n);
1606     PUSHs(SvTIED_obj(sv, mg));
1607     if (n > 1) {
1608         if (mg->mg_ptr) {
1609             if (mg->mg_len >= 0)
1610                 mPUSHp(mg->mg_ptr, mg->mg_len);
1611             else if (mg->mg_len == HEf_SVKEY)
1612                 PUSHs((SV*)mg->mg_ptr);
1613         }
1614         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1615             mPUSHi(mg->mg_len);
1616         }
1617     }
1618     if (n > 2) {
1619         PUSHs(val);
1620     }
1621     PUTBACK;
1622
1623     return call_method(meth, flags);
1624 }
1625
1626 STATIC int
1627 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1628 {
1629     dVAR; dSP;
1630
1631     ENTER;
1632     SAVETMPS;
1633     PUSHSTACKi(PERLSI_MAGIC);
1634
1635     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1636         sv_setsv(sv, *PL_stack_sp--);
1637     }
1638
1639     POPSTACK;
1640     FREETMPS;
1641     LEAVE;
1642     return 0;
1643 }
1644
1645 int
1646 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1647 {
1648     if (mg->mg_ptr)
1649         mg->mg_flags |= MGf_GSKIP;
1650     magic_methpack(sv,mg,"FETCH");
1651     return 0;
1652 }
1653
1654 int
1655 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1656 {
1657     dVAR; dSP;
1658     ENTER;
1659     PUSHSTACKi(PERLSI_MAGIC);
1660     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1661     POPSTACK;
1662     LEAVE;
1663     return 0;
1664 }
1665
1666 int
1667 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1668 {
1669     return magic_methpack(sv,mg,"DELETE");
1670 }
1671
1672
1673 U32
1674 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1675 {
1676     dVAR; dSP;
1677     I32 retval = 0;
1678
1679     ENTER;
1680     SAVETMPS;
1681     PUSHSTACKi(PERLSI_MAGIC);
1682     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1683         sv = *PL_stack_sp--;
1684         retval = SvIV(sv)-1;
1685         if (retval < -1)
1686             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1687     }
1688     POPSTACK;
1689     FREETMPS;
1690     LEAVE;
1691     return (U32) retval;
1692 }
1693
1694 int
1695 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1696 {
1697     dVAR; dSP;
1698
1699     ENTER;
1700     PUSHSTACKi(PERLSI_MAGIC);
1701     PUSHMARK(SP);
1702     XPUSHs(SvTIED_obj(sv, mg));
1703     PUTBACK;
1704     call_method("CLEAR", G_SCALAR|G_DISCARD);
1705     POPSTACK;
1706     LEAVE;
1707
1708     return 0;
1709 }
1710
1711 int
1712 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1713 {
1714     dVAR; dSP;
1715     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1716
1717     ENTER;
1718     SAVETMPS;
1719     PUSHSTACKi(PERLSI_MAGIC);
1720     PUSHMARK(SP);
1721     EXTEND(SP, 2);
1722     PUSHs(SvTIED_obj(sv, mg));
1723     if (SvOK(key))
1724         PUSHs(key);
1725     PUTBACK;
1726
1727     if (call_method(meth, G_SCALAR))
1728         sv_setsv(key, *PL_stack_sp--);
1729
1730     POPSTACK;
1731     FREETMPS;
1732     LEAVE;
1733     return 0;
1734 }
1735
1736 int
1737 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1738 {
1739     return magic_methpack(sv,mg,"EXISTS");
1740 }
1741
1742 SV *
1743 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1744 {
1745     dVAR; dSP;
1746     SV *retval;
1747     SV * const tied = SvTIED_obj((SV*)hv, mg);
1748     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1749
1750     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1751         SV *key;
1752         if (HvEITER_get(hv))
1753             /* we are in an iteration so the hash cannot be empty */
1754             return &PL_sv_yes;
1755         /* no xhv_eiter so now use FIRSTKEY */
1756         key = sv_newmortal();
1757         magic_nextpack((SV*)hv, mg, key);
1758         HvEITER_set(hv, NULL);     /* need to reset iterator */
1759         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1760     }
1761
1762     /* there is a SCALAR method that we can call */
1763     ENTER;
1764     PUSHSTACKi(PERLSI_MAGIC);
1765     PUSHMARK(SP);
1766     EXTEND(SP, 1);
1767     PUSHs(tied);
1768     PUTBACK;
1769
1770     if (call_method("SCALAR", G_SCALAR))
1771         retval = *PL_stack_sp--;
1772     else
1773         retval = &PL_sv_undef;
1774     POPSTACK;
1775     LEAVE;
1776     return retval;
1777 }
1778
1779 int
1780 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1781 {
1782     dVAR;
1783     GV * const gv = PL_DBline;
1784     const I32 i = SvTRUE(sv);
1785     SV ** const svp = av_fetch(GvAV(gv),
1786                      atoi(MgPV_nolen_const(mg)), FALSE);
1787     if (svp && SvIOKp(*svp)) {
1788         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1789         if (o) {
1790             /* set or clear breakpoint in the relevant control op */
1791             if (i)
1792                 o->op_flags |= OPf_SPECIAL;
1793             else
1794                 o->op_flags &= ~OPf_SPECIAL;
1795         }
1796     }
1797     return 0;
1798 }
1799
1800 int
1801 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1802 {
1803     dVAR;
1804     const AV * const obj = (AV*)mg->mg_obj;
1805     if (obj) {
1806         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1807     } else {
1808         SvOK_off(sv);
1809     }
1810     return 0;
1811 }
1812
1813 int
1814 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1815 {
1816     dVAR;
1817     AV * const obj = (AV*)mg->mg_obj;
1818     if (obj) {
1819         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1820     } else {
1821         if (ckWARN(WARN_MISC))
1822             Perl_warner(aTHX_ packWARN(WARN_MISC),
1823                         "Attempt to set length of freed array");
1824     }
1825     return 0;
1826 }
1827
1828 int
1829 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1830 {
1831     dVAR;
1832     PERL_UNUSED_ARG(sv);
1833     /* during global destruction, mg_obj may already have been freed */
1834     if (PL_in_clean_all)
1835         return 0;
1836
1837     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1838
1839     if (mg) {
1840         /* arylen scalar holds a pointer back to the array, but doesn't own a
1841            reference. Hence the we (the array) are about to go away with it
1842            still pointing at us. Clear its pointer, else it would be pointing
1843            at free memory. See the comment in sv_magic about reference loops,
1844            and why it can't own a reference to us.  */
1845         mg->mg_obj = 0;
1846     }
1847     return 0;
1848 }
1849
1850 int
1851 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1852 {
1853     dVAR;
1854     SV* const lsv = LvTARG(sv);
1855     PERL_UNUSED_ARG(mg);
1856
1857     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1858         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1859         if (found && found->mg_len >= 0) {
1860             I32 i = found->mg_len;
1861             if (DO_UTF8(lsv))
1862                 sv_pos_b2u(lsv, &i);
1863             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1864             return 0;
1865         }
1866     }
1867     SvOK_off(sv);
1868     return 0;
1869 }
1870
1871 int
1872 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1873 {
1874     dVAR;
1875     SV* const lsv = LvTARG(sv);
1876     SSize_t pos;
1877     STRLEN len;
1878     STRLEN ulen = 0;
1879     MAGIC* found;
1880
1881     PERL_UNUSED_ARG(mg);
1882
1883     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1884         found = mg_find(lsv, PERL_MAGIC_regex_global);
1885     else
1886         found = NULL;
1887     if (!found) {
1888         if (!SvOK(sv))
1889             return 0;
1890 #ifdef PERL_OLD_COPY_ON_WRITE
1891     if (SvIsCOW(lsv))
1892         sv_force_normal_flags(lsv, 0);
1893 #endif
1894         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1895                             NULL, 0);
1896     }
1897     else if (!SvOK(sv)) {
1898         found->mg_len = -1;
1899         return 0;
1900     }
1901     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1902
1903     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1904
1905     if (DO_UTF8(lsv)) {
1906         ulen = sv_len_utf8(lsv);
1907         if (ulen)
1908             len = ulen;
1909     }
1910
1911     if (pos < 0) {
1912         pos += len;
1913         if (pos < 0)
1914             pos = 0;
1915     }
1916     else if (pos > (SSize_t)len)
1917         pos = len;
1918
1919     if (ulen) {
1920         I32 p = pos;
1921         sv_pos_u2b(lsv, &p, 0);
1922         pos = p;
1923     }
1924
1925     found->mg_len = pos;
1926     found->mg_flags &= ~MGf_MINMATCH;
1927
1928     return 0;
1929 }
1930
1931 int
1932 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1933 {
1934     STRLEN len;
1935     SV * const lsv = LvTARG(sv);
1936     const char * const tmps = SvPV_const(lsv,len);
1937     I32 offs = LvTARGOFF(sv);
1938     I32 rem = LvTARGLEN(sv);
1939     PERL_UNUSED_ARG(mg);
1940
1941     if (SvUTF8(lsv))
1942         sv_pos_u2b(lsv, &offs, &rem);
1943     if (offs > (I32)len)
1944         offs = len;
1945     if (rem + offs > (I32)len)
1946         rem = len - offs;
1947     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1948     if (SvUTF8(lsv))
1949         SvUTF8_on(sv);
1950     return 0;
1951 }
1952
1953 int
1954 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1955 {
1956     dVAR;
1957     STRLEN len;
1958     const char * const tmps = SvPV_const(sv, len);
1959     SV * const lsv = LvTARG(sv);
1960     I32 lvoff = LvTARGOFF(sv);
1961     I32 lvlen = LvTARGLEN(sv);
1962     PERL_UNUSED_ARG(mg);
1963
1964     if (DO_UTF8(sv)) {
1965         sv_utf8_upgrade(lsv);
1966         sv_pos_u2b(lsv, &lvoff, &lvlen);
1967         sv_insert(lsv, lvoff, lvlen, tmps, len);
1968         LvTARGLEN(sv) = sv_len_utf8(sv);
1969         SvUTF8_on(lsv);
1970     }
1971     else if (lsv && SvUTF8(lsv)) {
1972         const char *utf8;
1973         sv_pos_u2b(lsv, &lvoff, &lvlen);
1974         LvTARGLEN(sv) = len;
1975         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1976         sv_insert(lsv, lvoff, lvlen, utf8, len);
1977         Safefree(utf8);
1978     }
1979     else {
1980         sv_insert(lsv, lvoff, lvlen, tmps, len);
1981         LvTARGLEN(sv) = len;
1982     }
1983
1984
1985     return 0;
1986 }
1987
1988 int
1989 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1990 {
1991     dVAR;
1992     PERL_UNUSED_ARG(sv);
1993     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
1994     return 0;
1995 }
1996
1997 int
1998 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1999 {
2000     dVAR;
2001     PERL_UNUSED_ARG(sv);
2002     /* update taint status */
2003     if (PL_tainted)
2004         mg->mg_len |= 1;
2005     else
2006         mg->mg_len &= ~1;
2007     return 0;
2008 }
2009
2010 int
2011 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2012 {
2013     SV * const lsv = LvTARG(sv);
2014     PERL_UNUSED_ARG(mg);
2015
2016     if (lsv)
2017         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2018     else
2019         SvOK_off(sv);
2020
2021     return 0;
2022 }
2023
2024 int
2025 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2026 {
2027     PERL_UNUSED_ARG(mg);
2028     do_vecset(sv);      /* XXX slurp this routine */
2029     return 0;
2030 }
2031
2032 int
2033 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2034 {
2035     dVAR;
2036     SV *targ = NULL;
2037     if (LvTARGLEN(sv)) {
2038         if (mg->mg_obj) {
2039             SV * const ahv = LvTARG(sv);
2040             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2041             if (he)
2042                 targ = HeVAL(he);
2043         }
2044         else {
2045             AV* const av = (AV*)LvTARG(sv);
2046             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2047                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2048         }
2049         if (targ && (targ != &PL_sv_undef)) {
2050             /* somebody else defined it for us */
2051             SvREFCNT_dec(LvTARG(sv));
2052             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2053             LvTARGLEN(sv) = 0;
2054             SvREFCNT_dec(mg->mg_obj);
2055             mg->mg_obj = NULL;
2056             mg->mg_flags &= ~MGf_REFCOUNTED;
2057         }
2058     }
2059     else
2060         targ = LvTARG(sv);
2061     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2062     return 0;
2063 }
2064
2065 int
2066 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2067 {
2068     PERL_UNUSED_ARG(mg);
2069     if (LvTARGLEN(sv))
2070         vivify_defelem(sv);
2071     if (LvTARG(sv)) {
2072         sv_setsv(LvTARG(sv), sv);
2073         SvSETMAGIC(LvTARG(sv));
2074     }
2075     return 0;
2076 }
2077
2078 void
2079 Perl_vivify_defelem(pTHX_ SV *sv)
2080 {
2081     dVAR;
2082     MAGIC *mg;
2083     SV *value = NULL;
2084
2085     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2086         return;
2087     if (mg->mg_obj) {
2088         SV * const ahv = LvTARG(sv);
2089         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2090         if (he)
2091             value = HeVAL(he);
2092         if (!value || value == &PL_sv_undef)
2093             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2094     }
2095     else {
2096         AV* const av = (AV*)LvTARG(sv);
2097         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2098             LvTARG(sv) = NULL;  /* array can't be extended */
2099         else {
2100             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2101             if (!svp || (value = *svp) == &PL_sv_undef)
2102                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2103         }
2104     }
2105     SvREFCNT_inc_simple_void(value);
2106     SvREFCNT_dec(LvTARG(sv));
2107     LvTARG(sv) = value;
2108     LvTARGLEN(sv) = 0;
2109     SvREFCNT_dec(mg->mg_obj);
2110     mg->mg_obj = NULL;
2111     mg->mg_flags &= ~MGf_REFCOUNTED;
2112 }
2113
2114 int
2115 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2116 {
2117     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2118 }
2119
2120 int
2121 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2122 {
2123     PERL_UNUSED_CONTEXT;
2124     mg->mg_len = -1;
2125     SvSCREAM_off(sv);
2126     return 0;
2127 }
2128
2129 int
2130 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2131 {
2132     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2133
2134     if (uf && uf->uf_set)
2135         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2136     return 0;
2137 }
2138
2139 int
2140 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2141 {
2142     const char type = mg->mg_type;
2143     if (type == PERL_MAGIC_qr) {
2144     } else if (type == PERL_MAGIC_bm) {
2145         SvTAIL_off(sv);
2146         SvVALID_off(sv);
2147     } else {
2148         assert(type == PERL_MAGIC_fm);
2149         SvCOMPILED_off(sv);
2150     }
2151     return sv_unmagic(sv, type);
2152 }
2153
2154 #ifdef USE_LOCALE_COLLATE
2155 int
2156 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2157 {
2158     /*
2159      * RenE<eacute> Descartes said "I think not."
2160      * and vanished with a faint plop.
2161      */
2162     PERL_UNUSED_CONTEXT;
2163     PERL_UNUSED_ARG(sv);
2164     if (mg->mg_ptr) {
2165         Safefree(mg->mg_ptr);
2166         mg->mg_ptr = NULL;
2167         mg->mg_len = -1;
2168     }
2169     return 0;
2170 }
2171 #endif /* USE_LOCALE_COLLATE */
2172
2173 /* Just clear the UTF-8 cache data. */
2174 int
2175 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2176 {
2177     PERL_UNUSED_CONTEXT;
2178     PERL_UNUSED_ARG(sv);
2179     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2180     mg->mg_ptr = NULL;
2181     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2182     return 0;
2183 }
2184
2185 int
2186 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2187 {
2188     dVAR;
2189     register const char *s;
2190     register I32 paren;
2191     register const REGEXP * rx;
2192     const char * const remaining = mg->mg_ptr + 1;
2193     I32 i;
2194     STRLEN len;
2195
2196     switch (*mg->mg_ptr) {
2197     case '\015': /* $^MATCH */
2198       if (strEQ(remaining, "ATCH"))
2199           goto do_match;
2200     case '`': /* ${^PREMATCH} caught below */
2201       do_prematch:
2202       paren = RX_BUFF_IDX_PREMATCH;
2203       goto setparen;
2204     case '\'': /* ${^POSTMATCH} caught below */
2205       do_postmatch:
2206       paren = RX_BUFF_IDX_POSTMATCH;
2207       goto setparen;
2208     case '&':
2209       do_match:
2210       paren = RX_BUFF_IDX_FULLMATCH;
2211       goto setparen;
2212     case '1': case '2': case '3': case '4':
2213     case '5': case '6': case '7': case '8': case '9':
2214       paren = atoi(mg->mg_ptr);
2215       setparen:
2216         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2217             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2218             break;
2219         } else {
2220             /* Croak with a READONLY error when a numbered match var is
2221              * set without a previous pattern match. Unless it's C<local $1>
2222              */
2223             if (!PL_localizing) {
2224                 Perl_croak(aTHX_ PL_no_modify);
2225             }
2226         }
2227     case '\001':        /* ^A */
2228         sv_setsv(PL_bodytarget, sv);
2229         break;
2230     case '\003':        /* ^C */
2231         PL_minus_c = (bool)SvIV(sv);
2232         break;
2233
2234     case '\004':        /* ^D */
2235 #ifdef DEBUGGING
2236         s = SvPV_nolen_const(sv);
2237         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2238         DEBUG_x(dump_all());
2239 #else
2240         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2241 #endif
2242         break;
2243     case '\005':  /* ^E */
2244         if (*(mg->mg_ptr+1) == '\0') {
2245 #ifdef MACOS_TRADITIONAL
2246             gMacPerl_OSErr = SvIV(sv);
2247 #else
2248 #  ifdef VMS
2249             set_vaxc_errno(SvIV(sv));
2250 #  else
2251 #    ifdef WIN32
2252             SetLastError( SvIV(sv) );
2253 #    else
2254 #      ifdef OS2
2255             os2_setsyserrno(SvIV(sv));
2256 #      else
2257             /* will anyone ever use this? */
2258             SETERRNO(SvIV(sv), 4);
2259 #      endif
2260 #    endif
2261 #  endif
2262 #endif
2263         }
2264         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2265             if (PL_encoding)
2266                 SvREFCNT_dec(PL_encoding);
2267             if (SvOK(sv) || SvGMAGICAL(sv)) {
2268                 PL_encoding = newSVsv(sv);
2269             }
2270             else {
2271                 PL_encoding = NULL;
2272             }
2273         }
2274         break;
2275     case '\006':        /* ^F */
2276         PL_maxsysfd = SvIV(sv);
2277         break;
2278     case '\010':        /* ^H */
2279         PL_hints = SvIV(sv);
2280         break;
2281     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2282         Safefree(PL_inplace);
2283         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2284         break;
2285     case '\017':        /* ^O */
2286         if (*(mg->mg_ptr+1) == '\0') {
2287             Safefree(PL_osname);
2288             PL_osname = NULL;
2289             if (SvOK(sv)) {
2290                 TAINT_PROPER("assigning to $^O");
2291                 PL_osname = savesvpv(sv);
2292             }
2293         }
2294         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2295             STRLEN len;
2296             const char *const start = SvPV(sv, len);
2297             const char *out = (const char*)memchr(start, '\0', len);
2298             SV *tmp;
2299             struct refcounted_he *tmp_he;
2300
2301
2302             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2303             PL_hints
2304                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2305
2306             /* Opening for input is more common than opening for output, so
2307                ensure that hints for input are sooner on linked list.  */
2308             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2309                                        SVs_TEMP | SvUTF8(sv))
2310                 : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv));
2311
2312             tmp_he
2313                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2314                                          newSVpvs_flags("open>", SVs_TEMP),
2315                                          tmp);
2316
2317             /* The UTF-8 setting is carried over  */
2318             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2319
2320             PL_compiling.cop_hints_hash
2321                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2322                                          newSVpvs_flags("open<", SVs_TEMP),
2323                                          tmp);
2324         }
2325         break;
2326     case '\020':        /* ^P */
2327       if (*remaining == '\0') { /* ^P */
2328           PL_perldb = SvIV(sv);
2329           if (PL_perldb && !PL_DBsingle)
2330               init_debugger();
2331           break;
2332       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2333           goto do_prematch;
2334       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2335           goto do_postmatch;
2336       }
2337     case '\024':        /* ^T */
2338 #ifdef BIG_TIME
2339         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2340 #else
2341         PL_basetime = (Time_t)SvIV(sv);
2342 #endif
2343         break;
2344     case '\025':        /* ^UTF8CACHE */
2345          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2346              PL_utf8cache = (signed char) sv_2iv(sv);
2347          }
2348          break;
2349     case '\027':        /* ^W & $^WARNING_BITS */
2350         if (*(mg->mg_ptr+1) == '\0') {
2351             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2352                 i = SvIV(sv);
2353                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2354                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2355             }
2356         }
2357         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2358             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2359                 if (!SvPOK(sv) && PL_localizing) {
2360                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2361                     PL_compiling.cop_warnings = pWARN_NONE;
2362                     break;
2363                 }
2364                 {
2365                     STRLEN len, i;
2366                     int accumulate = 0 ;
2367                     int any_fatals = 0 ;
2368                     const char * const ptr = SvPV_const(sv, len) ;
2369                     for (i = 0 ; i < len ; ++i) {
2370                         accumulate |= ptr[i] ;
2371                         any_fatals |= (ptr[i] & 0xAA) ;
2372                     }
2373                     if (!accumulate) {
2374                         if (!specialWARN(PL_compiling.cop_warnings))
2375                             PerlMemShared_free(PL_compiling.cop_warnings);
2376                         PL_compiling.cop_warnings = pWARN_NONE;
2377                     }
2378                     /* Yuck. I can't see how to abstract this:  */
2379                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2380                                        WARN_ALL) && !any_fatals) {
2381                         if (!specialWARN(PL_compiling.cop_warnings))
2382                             PerlMemShared_free(PL_compiling.cop_warnings);
2383                         PL_compiling.cop_warnings = pWARN_ALL;
2384                         PL_dowarn |= G_WARN_ONCE ;
2385                     }
2386                     else {
2387                         STRLEN len;
2388                         const char *const p = SvPV_const(sv, len);
2389
2390                         PL_compiling.cop_warnings
2391                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2392                                                          p, len);
2393
2394                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2395                             PL_dowarn |= G_WARN_ONCE ;
2396                     }
2397
2398                 }
2399             }
2400         }
2401         break;
2402     case '.':
2403         if (PL_localizing) {
2404             if (PL_localizing == 1)
2405                 SAVESPTR(PL_last_in_gv);
2406         }
2407         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2408             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2409         break;
2410     case '^':
2411         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2412         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2413         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2414         break;
2415     case '~':
2416         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2417         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2418         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2419         break;
2420     case '=':
2421         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2422         break;
2423     case '-':
2424         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2425         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2426             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2427         break;
2428     case '%':
2429         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2430         break;
2431     case '|':
2432         {
2433             IO * const io = GvIOp(PL_defoutgv);
2434             if(!io)
2435               break;
2436             if ((SvIV(sv)) == 0)
2437                 IoFLAGS(io) &= ~IOf_FLUSH;
2438             else {
2439                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2440                     PerlIO *ofp = IoOFP(io);
2441                     if (ofp)
2442                         (void)PerlIO_flush(ofp);
2443                     IoFLAGS(io) |= IOf_FLUSH;
2444                 }
2445             }
2446         }
2447         break;
2448     case '/':
2449         SvREFCNT_dec(PL_rs);
2450         PL_rs = newSVsv(sv);
2451         break;
2452     case '\\':
2453         if (PL_ors_sv)
2454             SvREFCNT_dec(PL_ors_sv);
2455         if (SvOK(sv) || SvGMAGICAL(sv)) {
2456             PL_ors_sv = newSVsv(sv);
2457         }
2458         else {
2459             PL_ors_sv = NULL;
2460         }
2461         break;
2462     case ',':
2463         if (PL_ofs_sv)
2464             SvREFCNT_dec(PL_ofs_sv);
2465         if (SvOK(sv) || SvGMAGICAL(sv)) {
2466             PL_ofs_sv = newSVsv(sv);
2467         }
2468         else {
2469             PL_ofs_sv = NULL;
2470         }
2471         break;
2472     case '[':
2473         CopARYBASE_set(&PL_compiling, SvIV(sv));
2474         break;
2475     case '?':
2476 #ifdef COMPLEX_STATUS
2477         if (PL_localizing == 2) {
2478             PL_statusvalue = LvTARGOFF(sv);
2479             PL_statusvalue_vms = LvTARGLEN(sv);
2480         }
2481         else
2482 #endif
2483 #ifdef VMSISH_STATUS
2484         if (VMSISH_STATUS)
2485             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2486         else
2487 #endif
2488             STATUS_UNIX_EXIT_SET(SvIV(sv));
2489         break;
2490     case '!':
2491         {
2492 #ifdef VMS
2493 #   define PERL_VMS_BANG vaxc$errno
2494 #else
2495 #   define PERL_VMS_BANG 0
2496 #endif
2497         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2498                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2499         }
2500         break;
2501     case '<':
2502         PL_uid = SvIV(sv);
2503         if (PL_delaymagic) {
2504             PL_delaymagic |= DM_RUID;
2505             break;                              /* don't do magic till later */
2506         }
2507 #ifdef HAS_SETRUID
2508         (void)setruid((Uid_t)PL_uid);
2509 #else
2510 #ifdef HAS_SETREUID
2511         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2512 #else
2513 #ifdef HAS_SETRESUID
2514       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2515 #else
2516         if (PL_uid == PL_euid) {                /* special case $< = $> */
2517 #ifdef PERL_DARWIN
2518             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2519             if (PL_uid != 0 && PerlProc_getuid() == 0)
2520                 (void)PerlProc_setuid(0);
2521 #endif
2522             (void)PerlProc_setuid(PL_uid);
2523         } else {
2524             PL_uid = PerlProc_getuid();
2525             Perl_croak(aTHX_ "setruid() not implemented");
2526         }
2527 #endif
2528 #endif
2529 #endif
2530         PL_uid = PerlProc_getuid();
2531         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2532         break;
2533     case '>':
2534         PL_euid = SvIV(sv);
2535         if (PL_delaymagic) {
2536             PL_delaymagic |= DM_EUID;
2537             break;                              /* don't do magic till later */
2538         }
2539 #ifdef HAS_SETEUID
2540         (void)seteuid((Uid_t)PL_euid);
2541 #else
2542 #ifdef HAS_SETREUID
2543         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2544 #else
2545 #ifdef HAS_SETRESUID
2546         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2547 #else
2548         if (PL_euid == PL_uid)          /* special case $> = $< */
2549             PerlProc_setuid(PL_euid);
2550         else {
2551             PL_euid = PerlProc_geteuid();
2552             Perl_croak(aTHX_ "seteuid() not implemented");
2553         }
2554 #endif
2555 #endif
2556 #endif
2557         PL_euid = PerlProc_geteuid();
2558         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2559         break;
2560     case '(':
2561         PL_gid = SvIV(sv);
2562         if (PL_delaymagic) {
2563             PL_delaymagic |= DM_RGID;
2564             break;                              /* don't do magic till later */
2565         }
2566 #ifdef HAS_SETRGID
2567         (void)setrgid((Gid_t)PL_gid);
2568 #else
2569 #ifdef HAS_SETREGID
2570         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2571 #else
2572 #ifdef HAS_SETRESGID
2573       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2574 #else
2575         if (PL_gid == PL_egid)                  /* special case $( = $) */
2576             (void)PerlProc_setgid(PL_gid);
2577         else {
2578             PL_gid = PerlProc_getgid();
2579             Perl_croak(aTHX_ "setrgid() not implemented");
2580         }
2581 #endif
2582 #endif
2583 #endif
2584         PL_gid = PerlProc_getgid();
2585         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2586         break;
2587     case ')':
2588 #ifdef HAS_SETGROUPS
2589         {
2590             const char *p = SvPV_const(sv, len);
2591             Groups_t *gary = NULL;
2592
2593             while (isSPACE(*p))
2594                 ++p;
2595             PL_egid = Atol(p);
2596             for (i = 0; i < NGROUPS; ++i) {
2597                 while (*p && !isSPACE(*p))
2598                     ++p;
2599                 while (isSPACE(*p))
2600                     ++p;
2601                 if (!*p)
2602                     break;
2603                 if(!gary)
2604                     Newx(gary, i + 1, Groups_t);
2605                 else
2606                     Renew(gary, i + 1, Groups_t);
2607                 gary[i] = Atol(p);
2608             }
2609             if (i)
2610                 (void)setgroups(i, gary);
2611             Safefree(gary);
2612         }
2613 #else  /* HAS_SETGROUPS */
2614         PL_egid = SvIV(sv);
2615 #endif /* HAS_SETGROUPS */
2616         if (PL_delaymagic) {
2617             PL_delaymagic |= DM_EGID;
2618             break;                              /* don't do magic till later */
2619         }
2620 #ifdef HAS_SETEGID
2621         (void)setegid((Gid_t)PL_egid);
2622 #else
2623 #ifdef HAS_SETREGID
2624         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2625 #else
2626 #ifdef HAS_SETRESGID
2627         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2628 #else
2629         if (PL_egid == PL_gid)                  /* special case $) = $( */
2630             (void)PerlProc_setgid(PL_egid);
2631         else {
2632             PL_egid = PerlProc_getegid();
2633             Perl_croak(aTHX_ "setegid() not implemented");
2634         }
2635 #endif
2636 #endif
2637 #endif
2638         PL_egid = PerlProc_getegid();
2639         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2640         break;
2641     case ':':
2642         PL_chopset = SvPV_force(sv,len);
2643         break;
2644 #ifndef MACOS_TRADITIONAL
2645     case '0':
2646         LOCK_DOLLARZERO_MUTEX;
2647 #ifdef HAS_SETPROCTITLE
2648         /* The BSDs don't show the argv[] in ps(1) output, they
2649          * show a string from the process struct and provide
2650          * the setproctitle() routine to manipulate that. */
2651         if (PL_origalen != 1) {
2652             s = SvPV_const(sv, len);
2653 #   if __FreeBSD_version > 410001
2654             /* The leading "-" removes the "perl: " prefix,
2655              * but not the "(perl) suffix from the ps(1)
2656              * output, because that's what ps(1) shows if the
2657              * argv[] is modified. */
2658             setproctitle("-%s", s);
2659 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2660             /* This doesn't really work if you assume that
2661              * $0 = 'foobar'; will wipe out 'perl' from the $0
2662              * because in ps(1) output the result will be like
2663              * sprintf("perl: %s (perl)", s)
2664              * I guess this is a security feature:
2665              * one (a user process) cannot get rid of the original name.
2666              * --jhi */
2667             setproctitle("%s", s);
2668 #   endif
2669         }
2670 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2671         if (PL_origalen != 1) {
2672              union pstun un;
2673              s = SvPV_const(sv, len);
2674              un.pst_command = (char *)s;
2675              pstat(PSTAT_SETCMD, un, len, 0, 0);
2676         }
2677 #else
2678         if (PL_origalen > 1) {
2679             /* PL_origalen is set in perl_parse(). */
2680             s = SvPV_force(sv,len);
2681             if (len >= (STRLEN)PL_origalen-1) {
2682                 /* Longer than original, will be truncated. We assume that
2683                  * PL_origalen bytes are available. */
2684                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2685             }
2686             else {
2687                 /* Shorter than original, will be padded. */
2688 #ifdef PERL_DARWIN
2689                 /* Special case for Mac OS X: see [perl #38868] */
2690                 const int pad = 0;
2691 #else
2692                 /* Is the space counterintuitive?  Yes.
2693                  * (You were expecting \0?)
2694                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2695                  * --jhi */
2696                 const int pad = ' ';
2697 #endif
2698                 Copy(s, PL_origargv[0], len, char);
2699                 PL_origargv[0][len] = 0;
2700                 memset(PL_origargv[0] + len + 1,
2701                        pad,  PL_origalen - len - 1);
2702             }
2703             PL_origargv[0][PL_origalen-1] = 0;
2704             for (i = 1; i < PL_origargc; i++)
2705                 PL_origargv[i] = 0;
2706         }
2707 #endif
2708         UNLOCK_DOLLARZERO_MUTEX;
2709         break;
2710 #endif
2711     }
2712     return 0;
2713 }
2714
2715 I32
2716 Perl_whichsig(pTHX_ const char *sig)
2717 {
2718     register char* const* sigv;
2719     PERL_UNUSED_CONTEXT;
2720
2721     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2722         if (strEQ(sig,*sigv))
2723             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2724 #ifdef SIGCLD
2725     if (strEQ(sig,"CHLD"))
2726         return SIGCLD;
2727 #endif
2728 #ifdef SIGCHLD
2729     if (strEQ(sig,"CLD"))
2730         return SIGCHLD;
2731 #endif
2732     return -1;
2733 }
2734
2735 Signal_t
2736 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2737 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2738 #else
2739 Perl_sighandler(int sig)
2740 #endif
2741 {
2742 #ifdef PERL_GET_SIG_CONTEXT
2743     dTHXa(PERL_GET_SIG_CONTEXT);
2744 #else
2745     dTHX;
2746 #endif
2747     dSP;
2748     GV *gv = NULL;
2749     SV *sv = NULL;
2750     SV * const tSv = PL_Sv;
2751     CV *cv = NULL;
2752     OP *myop = PL_op;
2753     U32 flags = 0;
2754     XPV * const tXpv = PL_Xpv;
2755
2756     if (PL_savestack_ix + 15 <= PL_savestack_max)
2757         flags |= 1;
2758     if (PL_markstack_ptr < PL_markstack_max - 2)
2759         flags |= 4;
2760     if (PL_scopestack_ix < PL_scopestack_max - 3)
2761         flags |= 16;
2762
2763     if (!PL_psig_ptr[sig]) {
2764                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2765                                  PL_sig_name[sig]);
2766                 exit(sig);
2767         }
2768
2769     /* Max number of items pushed there is 3*n or 4. We cannot fix
2770        infinity, so we fix 4 (in fact 5): */
2771     if (flags & 1) {
2772         PL_savestack_ix += 5;           /* Protect save in progress. */
2773         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2774     }
2775     if (flags & 4)
2776         PL_markstack_ptr++;             /* Protect mark. */
2777     if (flags & 16)
2778         PL_scopestack_ix += 1;
2779     /* sv_2cv is too complicated, try a simpler variant first: */
2780     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2781         || SvTYPE(cv) != SVt_PVCV) {
2782         HV *st;
2783         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2784     }
2785
2786     if (!cv || !CvROOT(cv)) {
2787         if (ckWARN(WARN_SIGNAL))
2788             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2789                 PL_sig_name[sig], (gv ? GvENAME(gv)
2790                                 : ((cv && CvGV(cv))
2791                                    ? GvENAME(CvGV(cv))
2792                                    : "__ANON__")));
2793         goto cleanup;
2794     }
2795
2796     if(PL_psig_name[sig]) {
2797         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2798         flags |= 64;
2799 #if !defined(PERL_IMPLICIT_CONTEXT)
2800         PL_sig_sv = sv;
2801 #endif
2802     } else {
2803         sv = sv_newmortal();
2804         sv_setpv(sv,PL_sig_name[sig]);
2805     }
2806
2807     PUSHSTACKi(PERLSI_SIGNAL);
2808     PUSHMARK(SP);
2809     PUSHs(sv);
2810 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2811     {
2812          struct sigaction oact;
2813
2814          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2815               if (sip) {
2816                    HV *sih = newHV();
2817                    SV *rv  = newRV_noinc((SV*)sih);
2818                    /* The siginfo fields signo, code, errno, pid, uid,
2819                     * addr, status, and band are defined by POSIX/SUSv3. */
2820                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2821                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
2822 #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. */
2823                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
2824                    hv_stores(sih, "status",     newSViv(sip->si_status));
2825                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
2826                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
2827                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
2828                    hv_stores(sih, "band",       newSViv(sip->si_band));
2829 #endif
2830                    EXTEND(SP, 2);
2831                    PUSHs((SV*)rv);
2832                    mPUSHp((char *)sip, sizeof(*sip));
2833               }
2834
2835          }
2836     }
2837 #endif
2838     PUTBACK;
2839
2840     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2841
2842     POPSTACK;
2843     if (SvTRUE(ERRSV)) {
2844 #ifndef PERL_MICRO
2845 #ifdef HAS_SIGPROCMASK
2846         /* Handler "died", for example to get out of a restart-able read().
2847          * Before we re-do that on its behalf re-enable the signal which was
2848          * blocked by the system when we entered.
2849          */
2850         sigset_t set;
2851         sigemptyset(&set);
2852         sigaddset(&set,sig);
2853         sigprocmask(SIG_UNBLOCK, &set, NULL);
2854 #else
2855         /* Not clear if this will work */
2856         (void)rsignal(sig, SIG_IGN);
2857         (void)rsignal(sig, PL_csighandlerp);
2858 #endif
2859 #endif /* !PERL_MICRO */
2860         Perl_die(aTHX_ NULL);
2861     }
2862 cleanup:
2863     if (flags & 1)
2864         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2865     if (flags & 4)
2866         PL_markstack_ptr--;
2867     if (flags & 16)
2868         PL_scopestack_ix -= 1;
2869     if (flags & 64)
2870         SvREFCNT_dec(sv);
2871     PL_op = myop;                       /* Apparently not needed... */
2872
2873     PL_Sv = tSv;                        /* Restore global temporaries. */
2874     PL_Xpv = tXpv;
2875     return;
2876 }
2877
2878
2879 static void
2880 S_restore_magic(pTHX_ const void *p)
2881 {
2882     dVAR;
2883     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2884     SV* const sv = mgs->mgs_sv;
2885
2886     if (!sv)
2887         return;
2888
2889     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2890     {
2891 #ifdef PERL_OLD_COPY_ON_WRITE
2892         /* While magic was saved (and off) sv_setsv may well have seen
2893            this SV as a prime candidate for COW.  */
2894         if (SvIsCOW(sv))
2895             sv_force_normal_flags(sv, 0);
2896 #endif
2897
2898         if (mgs->mgs_flags)
2899             SvFLAGS(sv) |= mgs->mgs_flags;
2900         else
2901             mg_magical(sv);
2902         if (SvGMAGICAL(sv)) {
2903             /* downgrade public flags to private,
2904                and discard any other private flags */
2905
2906             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2907             if (pubflags) {
2908                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2909                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2910             }
2911         }
2912     }
2913
2914     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2915
2916     /* If we're still on top of the stack, pop us off.  (That condition
2917      * will be satisfied if restore_magic was called explicitly, but *not*
2918      * if it's being called via leave_scope.)
2919      * The reason for doing this is that otherwise, things like sv_2cv()
2920      * may leave alloc gunk on the savestack, and some code
2921      * (e.g. sighandler) doesn't expect that...
2922      */
2923     if (PL_savestack_ix == mgs->mgs_ss_ix)
2924     {
2925         I32 popval = SSPOPINT;
2926         assert(popval == SAVEt_DESTRUCTOR_X);
2927         PL_savestack_ix -= 2;
2928         popval = SSPOPINT;
2929         assert(popval == SAVEt_ALLOC);
2930         popval = SSPOPINT;
2931         PL_savestack_ix -= popval;
2932     }
2933
2934 }
2935
2936 static void
2937 S_unwind_handler_stack(pTHX_ const void *p)
2938 {
2939     dVAR;
2940     const U32 flags = *(const U32*)p;
2941
2942     if (flags & 1)
2943         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2944 #if !defined(PERL_IMPLICIT_CONTEXT)
2945     if (flags & 64)
2946         SvREFCNT_dec(PL_sig_sv);
2947 #endif
2948 }
2949
2950 /*
2951 =for apidoc magic_sethint
2952
2953 Triggered by a store to %^H, records the key/value pair to
2954 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
2955 anything that would need a deep copy.  Maybe we should warn if we find a
2956 reference.
2957
2958 =cut
2959 */
2960 int
2961 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2962 {
2963     dVAR;
2964     SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
2965         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
2966
2967     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
2968        an alternative leaf in there, with PL_compiling.cop_hints being used if
2969        it's NULL. If needed for threads, the alternative could lock a mutex,
2970        or take other more complex action.  */
2971
2972     /* Something changed in %^H, so it will need to be restored on scope exit.
2973        Doing this here saves a lot of doing it manually in perl code (and
2974        forgetting to do it, and consequent subtle errors.  */
2975     PL_hints |= HINT_LOCALIZE_HH;
2976     PL_compiling.cop_hints_hash
2977         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
2978     return 0;
2979 }
2980
2981 /*
2982 =for apidoc magic_sethint
2983
2984 Triggered by a delete from %^H, records the key to
2985 C<PL_compiling.cop_hints_hash>.
2986
2987 =cut
2988 */
2989 int
2990 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
2991 {
2992     dVAR;
2993     PERL_UNUSED_ARG(sv);
2994
2995     assert(mg->mg_len == HEf_SVKEY);
2996
2997     PERL_UNUSED_ARG(sv);
2998
2999     PL_hints |= HINT_LOCALIZE_HH;
3000     PL_compiling.cop_hints_hash
3001         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3002                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
3003     return 0;
3004 }
3005
3006 /*
3007  * Local variables:
3008  * c-indentation-style: bsd
3009  * c-basic-offset: 4
3010  * indent-tabs-mode: t
3011  * End:
3012  *
3013  * ex: set ts=8 sts=4 sw=4 noet:
3014  */