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