mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "Sam sat on the ground and put his head in his hands.  'I wish I had never
  13  * come here, and I don't want to see no more magic,' he said, and fell silent."
  14  */
  15
  16 /*
  17 =head1 Magical Functions
  18
  19 "Magic" is special data attached to SV structures in order to give them
  20 "magical" properties.  When any Perl code tries to read from, or assign to,
  21 an SV marked as magical, it calls the 'get' or 'set' function associated
  22 with that SV's magic. A get is called prior to reading an SV, in order to
  23 give it a chance to update its internal value (get on $. writes the line
  24 number of the last read filehandle into to the SV's IV slot), while
  25 set is called after an SV has been written to, in order to allow it to make
  26 use of its changed value (set on $/ copies the SV's new value to the
  27 PL_rs global variable).
  28
  29 Magic is implemented as a linked list of MAGIC structures attached to the
  30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
  31 of functions that implement the get(), set(), length() etc functions,
  32 plus space for some flags and pointers. For example, a tied variable has
  33 a MAGIC structure that contains a pointer to the object associated with the
  34 tie.
  35
  36 */
  37
  38 #include "EXTERN.h"
  39 #define PERL_IN_MG_C
  40 #include "perl.h"
  41
  42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
  43 #  ifdef I_GRP
  44 #    include <grp.h>
  45 #  endif
  46 #endif
  47
  48 #if defined(HAS_SETGROUPS)
  49 #  ifndef NGROUPS
  50 #    define NGROUPS 32
  51 #  endif
  52 #endif
  53
  54 #ifdef __hpux
  55 #  include <sys/pstat.h>
  56 #endif
  57
  58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
  59 Signal_t Perl_csighandler(int sig, ...);
  60 #else
  61 Signal_t Perl_csighandler(int sig);
  62 #endif
  63
  64 #ifdef __Lynx__
  65 /* Missing protos on LynxOS */
  66 void setruid(uid_t id);
  67 void seteuid(uid_t id);
  68 void setrgid(uid_t id);
  69 void setegid(uid_t id);
  70 #endif
  71
  72 /*
  73  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  74  */
  75
  76 struct magic_state {
  77     SV* mgs_sv;
  78     U32 mgs_flags;
  79     I32 mgs_ss_ix;
  80 };
  81 /* MGS is typedef'ed to struct magic_state in perl.h */
  82
  83 STATIC void
  84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
  85 {
  86     dVAR;
  87     MGS* mgs;
  88     assert(SvMAGICAL(sv));
  89     /* Turning READONLY off for a copy-on-write scalar (including shared
  90        hash keys) is a bad idea.  */
  91     if (SvIsCOW(sv))
  92       sv_force_normal_flags(sv, 0);
  93
  94     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
  95
  96     mgs = SSPTR(mgs_ix, MGS*);
  97     mgs->mgs_sv = sv;
  98     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  99     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
 100
 101     SvMAGICAL_off(sv);
 102     SvREADONLY_off(sv);
 103     if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
 104         /* No public flags are set, so promote any private flags to public.  */
 105         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 106     }
 107 }
 108
 109 /*
 110 =for apidoc mg_magical
 111
 112 Turns on the magical status of an SV.  See C<sv_magic>.
 113
 114 =cut
 115 */
 116
 117 void
 118 Perl_mg_magical(pTHX_ SV *sv)
 119 {
 120     const MAGIC* mg;
 121     PERL_UNUSED_CONTEXT;
 122     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 123         const MGVTBL* const vtbl = mg->mg_virtual;
 124         if (vtbl) {
 125             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 126                 SvGMAGICAL_on(sv);
 127             if (vtbl->svt_set)
 128                 SvSMAGICAL_on(sv);
 129             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
 130                 SvRMAGICAL_on(sv);
 131         }
 132     }
 133 }
 134
 135
 136 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
 137
 138 STATIC bool
 139 S_is_container_magic(const MAGIC *mg)
 140 {
 141     switch (mg->mg_type) {
 142     case PERL_MAGIC_bm:
 143     case PERL_MAGIC_fm:
 144     case PERL_MAGIC_regex_global:
 145     case PERL_MAGIC_nkeys:
 146 #ifdef USE_LOCALE_COLLATE
 147     case PERL_MAGIC_collxfrm:
 148 #endif
 149     case PERL_MAGIC_qr:
 150     case PERL_MAGIC_taint:
 151     case PERL_MAGIC_vec:
 152     case PERL_MAGIC_vstring:
 153     case PERL_MAGIC_utf8:
 154     case PERL_MAGIC_substr:
 155     case PERL_MAGIC_defelem:
 156     case PERL_MAGIC_arylen:
 157     case PERL_MAGIC_pos:
 158     case PERL_MAGIC_backref:
 159     case PERL_MAGIC_arylen_p:
 160     case PERL_MAGIC_rhash:
 161     case PERL_MAGIC_symtab:
 162         return 0;
 163     default:
 164         return 1;
 165     }
 166 }
 167
 168 /*
 169 =for apidoc mg_get
 170
 171 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 172
 173 =cut
 174 */
 175
 176 int
 177 Perl_mg_get(pTHX_ SV *sv)
 178 {
 179     dVAR;
 180     const I32 mgs_ix = SSNEW(sizeof(MGS));
 181     const bool was_temp = (bool)SvTEMP(sv);
 182     int have_new = 0;
 183     MAGIC *newmg, *head, *cur, *mg;
 184     /* guard against sv having being freed midway by holding a private
 185        reference. */
 186
 187     /* sv_2mortal has this side effect of turning on the TEMP flag, which can
 188        cause the SV's buffer to get stolen (and maybe other stuff).
 189        So restore it.
 190     */
 191     sv_2mortal(SvREFCNT_inc_simple_NN(sv));
 192     if (!was_temp) {
 193         SvTEMP_off(sv);
 194     }
 195
 196     save_magic(mgs_ix, sv);
 197
 198     /* We must call svt_get(sv, mg) for each valid entry in the linked
 199        list of magic. svt_get() may delete the current entry, add new
 200        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 201
 202     newmg = cur = head = mg = SvMAGIC(sv);
 203     while (mg) {
 204         const MGVTBL * const vtbl = mg->mg_virtual;
 205
 206         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 207             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 208
 209             /* guard against magic having been deleted - eg FETCH calling
 210              * untie */
 211             if (!SvMAGIC(sv))
 212                 break;
 213
 214             /* Don't restore the flags for this entry if it was deleted. */
 215             if (mg->mg_flags & MGf_GSKIP)
 216                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
 217         }
 218
 219         mg = mg->mg_moremagic;
 220
 221         if (have_new) {
 222             /* Have we finished with the new entries we saw? Start again
 223                where we left off (unless there are more new entries). */
 224             if (mg == head) {
 225                 have_new = 0;
 226                 mg   = cur;
 227                 head = newmg;
 228             }
 229         }
 230
 231         /* Were any new entries added? */
 232         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
 233             have_new = 1;
 234             cur = mg;
 235             mg  = newmg;
 236         }
 237     }
 238
 239     restore_magic(INT2PTR(void *, (IV)mgs_ix));
 240
 241     if (SvREFCNT(sv) == 1) {
 242         /* We hold the last reference to this SV, which implies that the
 243            SV was deleted as a side effect of the routines we called.  */
 244         SvOK_off(sv);
 245     }
 246     return 0;
 247 }
 248
 249 /*
 250 =for apidoc mg_set
 251
 252 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 253
 254 =cut
 255 */
 256
 257 int
 258 Perl_mg_set(pTHX_ SV *sv)
 259 {
 260     dVAR;
 261     const I32 mgs_ix = SSNEW(sizeof(MGS));
 262     MAGIC* mg;
 263     MAGIC* nextmg;
 264
 265     save_magic(mgs_ix, sv);
 266
 267     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 268         const MGVTBL* vtbl = mg->mg_virtual;
 269         nextmg = mg->mg_moremagic;      /* it may delete itself */
 270         if (mg->mg_flags & MGf_GSKIP) {
 271             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 272             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
 273         }
 274         if (PL_localizing == 2 && !S_is_container_magic(mg))
 275             continue;
 276         if (vtbl && vtbl->svt_set)
 277             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
 278     }
 279
 280     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 281     return 0;
 282 }
 283
 284 /*
 285 =for apidoc mg_length
 286
 287 Report on the SV's length.  See C<sv_magic>.
 288
 289 =cut
 290 */
 291
 292 U32
 293 Perl_mg_length(pTHX_ SV *sv)
 294 {
 295     dVAR;
 296     MAGIC* mg;
 297     STRLEN len;
 298
 299     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 300         const MGVTBL * const vtbl = mg->mg_virtual;
 301         if (vtbl && vtbl->svt_len) {
 302             const I32 mgs_ix = SSNEW(sizeof(MGS));
 303             save_magic(mgs_ix, sv);
 304             /* omit MGf_GSKIP -- not changed here */
 305             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 306             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 307             return len;
 308         }
 309     }
 310
 311     if (DO_UTF8(sv)) {
 312         const U8 *s = (U8*)SvPV_const(sv, len);
 313         len = utf8_length(s, s + len);
 314     }
 315     else
 316         (void)SvPV_const(sv, len);
 317     return len;
 318 }
 319
 320 I32
 321 Perl_mg_size(pTHX_ SV *sv)
 322 {
 323     MAGIC* mg;
 324
 325     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 326         const MGVTBL* const vtbl = mg->mg_virtual;
 327         if (vtbl && vtbl->svt_len) {
 328             const I32 mgs_ix = SSNEW(sizeof(MGS));
 329             I32 len;
 330             save_magic(mgs_ix, sv);
 331             /* omit MGf_GSKIP -- not changed here */
 332             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 333             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 334             return len;
 335         }
 336     }
 337
 338     switch(SvTYPE(sv)) {
 339         case SVt_PVAV:
 340             return AvFILLp((AV *) sv); /* Fallback to non-tied array */
 341         case SVt_PVHV:
 342             /* FIXME */
 343         default:
 344             Perl_croak(aTHX_ "Size magic not implemented");
 345             break;
 346     }
 347     return 0;
 348 }
 349
 350 /*
 351 =for apidoc mg_clear
 352
 353 Clear something magical that the SV represents.  See C<sv_magic>.
 354
 355 =cut
 356 */
 357
 358 int
 359 Perl_mg_clear(pTHX_ SV *sv)
 360 {
 361     const I32 mgs_ix = SSNEW(sizeof(MGS));
 362     MAGIC* mg;
 363
 364     save_magic(mgs_ix, sv);
 365
 366     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 367         const MGVTBL* const vtbl = mg->mg_virtual;
 368         /* omit GSKIP -- never set here */
 369
 370         if (vtbl && vtbl->svt_clear)
 371             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 372     }
 373
 374     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 375     return 0;
 376 }
 377
 378 /*
 379 =for apidoc mg_find
 380
 381 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 382
 383 =cut
 384 */
 385
 386 MAGIC*
 387 Perl_mg_find(pTHX_ const SV *sv, int type)
 388 {
 389     PERL_UNUSED_CONTEXT;
 390     if (sv) {
 391         MAGIC *mg;
 392         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 393             if (mg->mg_type == type)
 394                 return mg;
 395         }
 396     }
 397     return NULL;
 398 }
 399
 400 /*
 401 =for apidoc mg_copy
 402
 403 Copies the magic from one SV to another.  See C<sv_magic>.
 404
 405 =cut
 406 */
 407
 408 int
 409 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 410 {
 411     int count = 0;
 412     MAGIC* mg;
 413     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 414         const MGVTBL* const vtbl = mg->mg_virtual;
 415         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 416             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 417         }
 418         else {
 419             const char type = mg->mg_type;
 420             if (isUPPER(type) && type != PERL_MAGIC_uvar) {
 421                 sv_magic(nsv,
 422                      (type == PERL_MAGIC_tied)
 423                         ? SvTIED_obj(sv, mg)
 424                         : (type == PERL_MAGIC_regdata && mg->mg_obj)
 425                             ? sv
 426                             : mg->mg_obj,
 427                      toLOWER(type), key, klen);
 428                 count++;
 429             }
 430         }
 431     }
 432     return count;
 433 }
 434
 435 /*
 436 =for apidoc mg_localize
 437
 438 Copy some of the magic from an existing SV to new localized version of
 439 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
 440 doesn't (eg taint, pos).
 441
 442 =cut
 443 */
 444
 445 void
 446 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
 447 {
 448     dVAR;
 449     MAGIC *mg;
 450     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 451         const MGVTBL* const vtbl = mg->mg_virtual;
 452         if (!S_is_container_magic(mg))
 453             continue;
 454
 455         if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
 456             (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
 457         else
 458             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 459                             mg->mg_ptr, mg->mg_len);
 460
 461         /* container types should remain read-only across localization */
 462         SvFLAGS(nsv) |= SvREADONLY(sv);
 463     }
 464
 465     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 466         SvFLAGS(nsv) |= SvMAGICAL(sv);
 467         PL_localizing = 1;
 468         SvSETMAGIC(nsv);
 469         PL_localizing = 0;
 470     }
 471 }
 472
 473 /*
 474 =for apidoc mg_free
 475
 476 Free any magic storage used by the SV.  See C<sv_magic>.
 477
 478 =cut
 479 */
 480
 481 int
 482 Perl_mg_free(pTHX_ SV *sv)
 483 {
 484     MAGIC* mg;
 485     MAGIC* moremagic;
 486     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 487         const MGVTBL* const vtbl = mg->mg_virtual;
 488         moremagic = mg->mg_moremagic;
 489         if (vtbl && vtbl->svt_free)
 490             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 491         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 492             if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 493                 Safefree(mg->mg_ptr);
 494             else if (mg->mg_len == HEf_SVKEY)
 495                 SvREFCNT_dec((SV*)mg->mg_ptr);
 496         }
 497         if (mg->mg_flags & MGf_REFCOUNTED)
 498             SvREFCNT_dec(mg->mg_obj);
 499         Safefree(mg);
 500     }
 501     SvMAGIC_set(sv, NULL);
 502     return 0;
 503 }
 504
 505 #include <signal.h>
 506
 507 U32
 508 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 509 {
 510     dVAR;
 511     PERL_UNUSED_ARG(sv);
 512
 513     if (PL_curpm) {
 514         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 515         if (rx) {
 516             if (mg->mg_obj) {                   /* @+ */
 517                 /* return the number possible */
 518                 return rx->nparens;
 519             } else {                            /* @- */
 520                 I32 paren = rx->lastparen;
 521
 522                 /* return the last filled */
 523                 while ( paren >= 0
 524                         && (rx->offs[paren].start == -1
 525                             || rx->offs[paren].end == -1) )
 526                     paren--;
 527                 return (U32)paren;
 528             }
 529         }
 530     }
 531
 532     return (U32)-1;
 533 }
 534
 535 int
 536 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 537 {
 538     dVAR;
 539     if (PL_curpm) {
 540         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 541         if (rx) {
 542             register const I32 paren = mg->mg_len;
 543             register I32 s;
 544             register I32 t;
 545             if (paren < 0)
 546                 return 0;
 547             if (paren <= (I32)rx->nparens &&
 548                 (s = rx->offs[paren].start) != -1 &&
 549                 (t = rx->offs[paren].end) != -1)
 550                 {
 551                     register I32 i;
 552                     if (mg->mg_obj)             /* @+ */
 553                         i = t;
 554                     else                        /* @- */
 555                         i = s;
 556
 557                     if (i > 0 && RX_MATCH_UTF8(rx)) {
 558                         const char * const b = rx->subbeg;
 559                         if (b)
 560                             i = utf8_length((U8*)b, (U8*)(b+i));
 561                     }
 562
 563                     sv_setiv(sv, i);
 564                 }
 565         }
 566     }
 567     return 0;
 568 }
 569
 570 int
 571 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 572 {
 573     PERL_UNUSED_ARG(sv);
 574     PERL_UNUSED_ARG(mg);
 575     Perl_croak(aTHX_ PL_no_modify);
 576     NORETURN_FUNCTION_END;
 577 }
 578
 579 U32
 580 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 581 {
 582     dVAR;
 583     register I32 paren;
 584     register I32 i;
 585     register const REGEXP * rx;
 586     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         if (PL_inplace)
 786             sv_setpv(sv, PL_inplace);
 787         else
 788             sv_setsv(sv, &PL_sv_undef);
 789         break;
 790     case '\017':                /* ^O & ^OPEN */
 791         if (nextchar == '\0') {
 792             sv_setpv(sv, PL_osname);
 793             SvTAINTED_off(sv);
 794         }
 795         else if (strEQ(remaining, "PEN")) {
 796             Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
 797         }
 798         break;
 799     case '\020':
 800         if (nextchar == '\0') {       /* ^P */
 801             sv_setiv(sv, (IV)PL_perldb);
 802         } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
 803             goto do_prematch_fetch;
 804         } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
 805             goto do_postmatch_fetch;
 806         }
 807         break;
 808     case '\023':                /* ^S */
 809         if (nextchar == '\0') {
 810             if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
 811                 SvOK_off(sv);
 812             else if (PL_in_eval)
 813                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 814             else
 815                 sv_setiv(sv, 0);
 816         }
 817         break;
 818     case '\024':                /* ^T */
 819         if (nextchar == '\0') {
 820 #ifdef BIG_TIME
 821             sv_setnv(sv, PL_basetime);
 822 #else
 823             sv_setiv(sv, (IV)PL_basetime);
 824 #endif
 825         }
 826         else if (strEQ(remaining, "AINT"))
 827             sv_setiv(sv, PL_tainting
 828                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 829                     : 0);
 830         break;
 831     case '\025':                /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
 832         if (strEQ(remaining, "NICODE"))
 833             sv_setuv(sv, (UV) PL_unicode);
 834         else if (strEQ(remaining, "TF8LOCALE"))
 835             sv_setuv(sv, (UV) PL_utf8locale);
 836         else if (strEQ(remaining, "TF8CACHE"))
 837             sv_setiv(sv, (IV) PL_utf8cache);
 838         break;
 839     case '\027':                /* ^W  & $^WARNING_BITS */
 840         if (nextchar == '\0')
 841             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 842         else if (strEQ(remaining, "ARNING_BITS")) {
 843             if (PL_compiling.cop_warnings == pWARN_NONE) {
 844                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 845             }
 846             else if (PL_compiling.cop_warnings == pWARN_STD) {
 847                 sv_setpvn(
 848                     sv,
 849                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 850                     WARNsize
 851                 );
 852             }
 853             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 854                 /* Get the bit mask for $warnings::Bits{all}, because
 855                  * it could have been extended by warnings::register */
 856                 HV * const bits=get_hv("warnings::Bits", FALSE);
 857                 if (bits) {
 858                     SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
 859                     if (bits_all)
 860                         sv_setsv(sv, *bits_all);
 861                 }
 862                 else {
 863                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 864                 }
 865             }
 866             else {
 867                 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
 868                           *PL_compiling.cop_warnings);
 869             }
 870             SvPOK_only(sv);
 871         }
 872         break;
 873     case '\015': /* $^MATCH */
 874         if (strEQ(remaining, "ATCH")) {
 875     case '1': case '2': case '3': case '4':
 876     case '5': case '6': case '7': case '8': case '9': case '&':
 877             if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 878                 /*
 879                  * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 880                  * XXX Does the new way break anything?
 881                  */
 882                 paren = atoi(mg->mg_ptr); /* $& is in [0] */
 883                 CALLREG_NUMBUF_FETCH(rx,paren,sv);
 884                 break;
 885             }
 886             sv_setsv(sv,&PL_sv_undef);
 887         }
 888         break;
 889     case '+':
 890         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 891             if (rx->lastparen) {
 892                 CALLREG_NUMBUF_FETCH(rx,rx->lastparen,sv);
 893                 break;
 894             }
 895         }
 896         sv_setsv(sv,&PL_sv_undef);
 897         break;
 898     case '\016':                /* ^N */
 899         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 900             if (rx->lastcloseparen) {
 901                 CALLREG_NUMBUF_FETCH(rx,rx->lastcloseparen,sv);
 902                 break;
 903             }
 904
 905         }
 906         sv_setsv(sv,&PL_sv_undef);
 907         break;
 908     case '`':
 909       do_prematch_fetch:
 910         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 911             CALLREG_NUMBUF_FETCH(rx,-2,sv);
 912             break;
 913         }
 914         sv_setsv(sv,&PL_sv_undef);
 915         break;
 916     case '\'':
 917       do_postmatch_fetch:
 918         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 919             CALLREG_NUMBUF_FETCH(rx,-1,sv);
 920             break;
 921         }
 922         sv_setsv(sv,&PL_sv_undef);
 923         break;
 924     case '.':
 925         if (GvIO(PL_last_in_gv)) {
 926             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 927         }
 928         break;
 929     case '?':
 930         {
 931             sv_setiv(sv, (IV)STATUS_CURRENT);
 932 #ifdef COMPLEX_STATUS
 933             LvTARGOFF(sv) = PL_statusvalue;
 934             LvTARGLEN(sv) = PL_statusvalue_vms;
 935 #endif
 936         }
 937         break;
 938     case '^':
 939         if (GvIOp(PL_defoutgv))
 940             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 941         if (s)
 942             sv_setpv(sv,s);
 943         else {
 944             sv_setpv(sv,GvENAME(PL_defoutgv));
 945             sv_catpv(sv,"_TOP");
 946         }
 947         break;
 948     case '~':
 949         if (GvIOp(PL_defoutgv))
 950             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 951         if (!s)
 952             s = GvENAME(PL_defoutgv);
 953         sv_setpv(sv,s);
 954         break;
 955     case '=':
 956         if (GvIOp(PL_defoutgv))
 957             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 958         break;
 959     case '-':
 960         if (GvIOp(PL_defoutgv))
 961             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 962         break;
 963     case '%':
 964         if (GvIOp(PL_defoutgv))
 965             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 966         break;
 967     case ':':
 968         break;
 969     case '/':
 970         break;
 971     case '[':
 972         sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
 973         break;
 974     case '|':
 975         if (GvIOp(PL_defoutgv))
 976             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 977         break;
 978     case ',':
 979         break;
 980     case '\\':
 981         if (PL_ors_sv)
 982             sv_copypv(sv, PL_ors_sv);
 983         break;
 984     case '!':
 985 #ifdef VMS
 986         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 987         sv_setpv(sv, errno ? Strerror(errno) : "");
 988 #else
 989         {
 990         const int saveerrno = errno;
 991         sv_setnv(sv, (NV)errno);
 992 #ifdef OS2
 993         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 994             sv_setpv(sv, os2error(Perl_rc));
 995         else
 996 #endif
 997         sv_setpv(sv, errno ? Strerror(errno) : "");
 998         errno = saveerrno;
 999         }
1000 #endif
1001         SvRTRIM(sv);
1002         SvNOK_on(sv);   /* what a wonderful hack! */
1003         break;
1004     case '<':
1005         sv_setiv(sv, (IV)PL_uid);
1006         break;
1007     case '>':
1008         sv_setiv(sv, (IV)PL_euid);
1009         break;
1010     case '(':
1011         sv_setiv(sv, (IV)PL_gid);
1012         goto add_groups;
1013     case ')':
1014         sv_setiv(sv, (IV)PL_egid);
1015       add_groups:
1016 #ifdef HAS_GETGROUPS
1017         {
1018             Groups_t *gary = NULL;
1019             I32 i, num_groups = getgroups(0, gary);
1020             Newx(gary, num_groups, Groups_t);
1021             num_groups = getgroups(num_groups, gary);
1022             for (i = 0; i < num_groups; i++)
1023                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1024             Safefree(gary);
1025         }
1026         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1027 #endif
1028         break;
1029 #ifndef MACOS_TRADITIONAL
1030     case '0':
1031         break;
1032 #endif
1033     }
1034     return 0;
1035 }
1036
1037 int
1038 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1039 {
1040     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1041
1042     if (uf && uf->uf_val)
1043         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1044     return 0;
1045 }
1046
1047 int
1048 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1049 {
1050     dVAR;
1051     STRLEN len = 0, klen;
1052     const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1053     const char * const ptr = MgPV_const(mg,klen);
1054     my_setenv(ptr, s);
1055
1056 #ifdef DYNAMIC_ENV_FETCH
1057      /* We just undefd an environment var.  Is a replacement */
1058      /* waiting in the wings? */
1059     if (!len) {
1060         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1061         if (valp)
1062             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1063     }
1064 #endif
1065
1066 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1067                             /* And you'll never guess what the dog had */
1068                             /*   in its mouth... */
1069     if (PL_tainting) {
1070         MgTAINTEDDIR_off(mg);
1071 #ifdef VMS
1072         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1073             char pathbuf[256], eltbuf[256], *cp, *elt;
1074             Stat_t sbuf;
1075             int i = 0, j = 0;
1076
1077             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1078             elt = eltbuf;
1079             do {          /* DCL$PATH may be a search list */
1080                 while (1) {   /* as may dev portion of any element */
1081                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1082                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1083                              cando_by_name(S_IWUSR,0,elt) ) {
1084                             MgTAINTEDDIR_on(mg);
1085                             return 0;
1086                         }
1087                     }
1088                     if ((cp = strchr(elt, ':')) != NULL)
1089                         *cp = '\0';
1090                     if (my_trnlnm(elt, eltbuf, j++))
1091                         elt = eltbuf;
1092                     else
1093                         break;
1094                 }
1095                 j = 0;
1096             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1097         }
1098 #endif /* VMS */
1099         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1100             const char * const strend = s + len;
1101
1102             while (s < strend) {
1103                 char tmpbuf[256];
1104                 Stat_t st;
1105                 I32 i;
1106 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1107                 const char path_sep = '|';
1108 #else
1109                 const char path_sep = ':';
1110 #endif
1111                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1112                              s, strend, path_sep, &i);
1113                 s++;
1114                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1115 #ifdef VMS
1116                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1117 #else
1118                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1119 #endif
1120                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1121                     MgTAINTEDDIR_on(mg);
1122                     return 0;
1123                 }
1124             }
1125         }
1126     }
1127 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1128
1129     return 0;
1130 }
1131
1132 int
1133 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1134 {
1135     PERL_UNUSED_ARG(sv);
1136     my_setenv(MgPV_nolen_const(mg),NULL);
1137     return 0;
1138 }
1139
1140 int
1141 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1142 {
1143     dVAR;
1144     PERL_UNUSED_ARG(mg);
1145 #if defined(VMS)
1146     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1147 #else
1148     if (PL_localizing) {
1149         HE* entry;
1150         my_clearenv();
1151         hv_iterinit((HV*)sv);
1152         while ((entry = hv_iternext((HV*)sv))) {
1153             I32 keylen;
1154             my_setenv(hv_iterkey(entry, &keylen),
1155                       SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
1156         }
1157     }
1158 #endif
1159     return 0;
1160 }
1161
1162 int
1163 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1164 {
1165     dVAR;
1166     PERL_UNUSED_ARG(sv);
1167     PERL_UNUSED_ARG(mg);
1168 #if defined(VMS)
1169     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1170 #else
1171     my_clearenv();
1172 #endif
1173     return 0;
1174 }
1175
1176 #ifndef PERL_MICRO
1177 #ifdef HAS_SIGPROCMASK
1178 static void
1179 restore_sigmask(pTHX_ SV *save_sv)
1180 {
1181     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1182     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1183 }
1184 #endif
1185 int
1186 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1187 {
1188     dVAR;
1189     /* Are we fetching a signal entry? */
1190     const I32 i = whichsig(MgPV_nolen_const(mg));
1191     if (i > 0) {
1192         if(PL_psig_ptr[i])
1193             sv_setsv(sv,PL_psig_ptr[i]);
1194         else {
1195             Sighandler_t sigstate = rsignal_state(i);
1196 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1197             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1198                 sigstate = SIG_IGN;
1199 #endif
1200 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1201             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1202                 sigstate = SIG_DFL;
1203 #endif
1204             /* cache state so we don't fetch it again */
1205             if(sigstate == (Sighandler_t) SIG_IGN)
1206                 sv_setpvs(sv,"IGNORE");
1207             else
1208                 sv_setsv(sv,&PL_sv_undef);
1209             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1210             SvTEMP_off(sv);
1211         }
1212     }
1213     return 0;
1214 }
1215 int
1216 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1217 {
1218     /* XXX Some of this code was copied from Perl_magic_setsig. A little
1219      * refactoring might be in order.
1220      */
1221     dVAR;
1222     register const char * const s = MgPV_nolen_const(mg);
1223     PERL_UNUSED_ARG(sv);
1224     if (*s == '_') {
1225         SV** svp = NULL;
1226         if (strEQ(s,"__DIE__"))
1227             svp = &PL_diehook;
1228         else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
1229             svp = &PL_warnhook;
1230         if (svp && *svp) {
1231             SV *const to_dec = *svp;
1232             *svp = NULL;
1233             SvREFCNT_dec(to_dec);
1234         }
1235     }
1236     else {
1237         /* Are we clearing a signal entry? */
1238         const I32 i = whichsig(s);
1239         if (i > 0) {
1240 #ifdef HAS_SIGPROCMASK
1241             sigset_t set, save;
1242             SV* save_sv;
1243             /* Avoid having the signal arrive at a bad time, if possible. */
1244             sigemptyset(&set);
1245             sigaddset(&set,i);
1246             sigprocmask(SIG_BLOCK, &set, &save);
1247             ENTER;
1248             save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1249             SAVEFREESV(save_sv);
1250             SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1251 #endif
1252             PERL_ASYNC_CHECK();
1253 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1254             if (!PL_sig_handlers_initted) Perl_csighandler_init();
1255 #endif
1256 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1257             PL_sig_defaulting[i] = 1;
1258             (void)rsignal(i, PL_csighandlerp);
1259 #else
1260             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1261 #endif
1262             if(PL_psig_name[i]) {
1263                 SvREFCNT_dec(PL_psig_name[i]);
1264                 PL_psig_name[i]=0;
1265             }
1266             if(PL_psig_ptr[i]) {
1267                 SV * const to_dec=PL_psig_ptr[i];
1268                 PL_psig_ptr[i]=0;
1269                 LEAVE;
1270                 SvREFCNT_dec(to_dec);
1271             }
1272             else
1273                 LEAVE;
1274         }
1275     }
1276     return 0;
1277 }
1278
1279 /*
1280  * The signal handling nomenclature has gotten a bit confusing since the advent of
1281  * safe signals.  S_raise_signal only raises signals by analogy with what the
1282  * underlying system's signal mechanism does.  It might be more proper to say that
1283  * it defers signals that have already been raised and caught.
1284  *
1285  * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending
1286  * in the sense of being on the system's signal queue in between raising and delivery.
1287  * They are only pending on Perl's deferral list, i.e., they track deferred signals
1288  * awaiting delivery after the current Perl opcode completes and say nothing about
1289  * signals raised but not yet caught in the underlying signal implementation.
1290  */
1291
1292 #ifndef SIG_PENDING_DIE_COUNT
1293 #  define SIG_PENDING_DIE_COUNT 120
1294 #endif
1295
1296 static void
1297 S_raise_signal(pTHX_ int sig)
1298 {
1299     dVAR;
1300     /* Set a flag to say this signal is pending */
1301     PL_psig_pend[sig]++;
1302     /* And one to say _a_ signal is pending */
1303     if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1304         Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1305                 (unsigned long)SIG_PENDING_DIE_COUNT);
1306 }
1307
1308 Signal_t
1309 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1310 Perl_csighandler(int sig, ...)
1311 #else
1312 Perl_csighandler(int sig)
1313 #endif
1314 {
1315 #ifdef PERL_GET_SIG_CONTEXT
1316     dTHXa(PERL_GET_SIG_CONTEXT);
1317 #else
1318     dTHX;
1319 #endif
1320 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1321    va_list args;
1322 #endif
1323 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1324     (void) rsignal(sig, PL_csighandlerp);
1325     if (PL_sig_ignoring[sig]) return;
1326 #endif
1327 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1328     if (PL_sig_defaulting[sig])
1329 #ifdef KILL_BY_SIGPRC
1330             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1331 #else
1332             exit(1);
1333 #endif
1334 #endif
1335 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1336    va_start(args, sig);
1337 #endif
1338    if (
1339 #ifdef SIGILL
1340            sig == SIGILL ||
1341 #endif
1342 #ifdef SIGBUS
1343            sig == SIGBUS ||
1344 #endif
1345 #ifdef SIGSEGV
1346            sig == SIGSEGV ||
1347 #endif
1348            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1349         /* Call the perl level handler now--
1350          * with risk we may be in malloc() etc. */
1351         (*PL_sighandlerp)(sig);
1352    else
1353         S_raise_signal(aTHX_ sig);
1354 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1355    va_end(args);
1356 #endif
1357 }
1358
1359 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1360 void
1361 Perl_csighandler_init(void)
1362 {
1363     int sig;
1364     if (PL_sig_handlers_initted) return;
1365
1366     for (sig = 1; sig < SIG_SIZE; sig++) {
1367 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1368         dTHX;
1369         PL_sig_defaulting[sig] = 1;
1370         (void) rsignal(sig, PL_csighandlerp);
1371 #endif
1372 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1373         PL_sig_ignoring[sig] = 0;
1374 #endif
1375     }
1376     PL_sig_handlers_initted = 1;
1377 }
1378 #endif
1379
1380 void
1381 Perl_despatch_signals(pTHX)
1382 {
1383     dVAR;
1384     int sig;
1385     PL_sig_pending = 0;
1386     for (sig = 1; sig < SIG_SIZE; sig++) {
1387         if (PL_psig_pend[sig]) {
1388             PERL_BLOCKSIG_ADD(set, sig);
1389             PL_psig_pend[sig] = 0;
1390             PERL_BLOCKSIG_BLOCK(set);
1391             (*PL_sighandlerp)(sig);
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 = newSVpv((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_setglob(pTHX_ SV *sv, MAGIC *mg)
1932 {
1933     GV* gv;
1934     PERL_UNUSED_ARG(mg);
1935
1936     Perl_croak(aTHX_ "Perl_magic_setglob is dead code?");
1937
1938     if (!SvOK(sv))
1939         return 0;
1940     if (isGV_with_GP(sv)) {
1941         /* We're actually already a typeglob, so don't need the stuff below.
1942          */
1943         return 0;
1944     }
1945     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1946     if (sv == (SV*)gv)
1947         return 0;
1948     if (GvGP(sv))
1949         gp_free((GV*)sv);
1950     GvGP(sv) = gp_ref(GvGP(gv));
1951     return 0;
1952 }
1953
1954 int
1955 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1956 {
1957     STRLEN len;
1958     SV * const lsv = LvTARG(sv);
1959     const char * const tmps = SvPV_const(lsv,len);
1960     I32 offs = LvTARGOFF(sv);
1961     I32 rem = LvTARGLEN(sv);
1962     PERL_UNUSED_ARG(mg);
1963
1964     if (SvUTF8(lsv))
1965         sv_pos_u2b(lsv, &offs, &rem);
1966     if (offs > (I32)len)
1967         offs = len;
1968     if (rem + offs > (I32)len)
1969         rem = len - offs;
1970     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1971     if (SvUTF8(lsv))
1972         SvUTF8_on(sv);
1973     return 0;
1974 }
1975
1976 int
1977 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1978 {
1979     dVAR;
1980     STRLEN len;
1981     const char * const tmps = SvPV_const(sv, len);
1982     SV * const lsv = LvTARG(sv);
1983     I32 lvoff = LvTARGOFF(sv);
1984     I32 lvlen = LvTARGLEN(sv);
1985     PERL_UNUSED_ARG(mg);
1986
1987     if (DO_UTF8(sv)) {
1988         sv_utf8_upgrade(lsv);
1989         sv_pos_u2b(lsv, &lvoff, &lvlen);
1990         sv_insert(lsv, lvoff, lvlen, tmps, len);
1991         LvTARGLEN(sv) = sv_len_utf8(sv);
1992         SvUTF8_on(lsv);
1993     }
1994     else if (lsv && SvUTF8(lsv)) {
1995         const char *utf8;
1996         sv_pos_u2b(lsv, &lvoff, &lvlen);
1997         LvTARGLEN(sv) = len;
1998         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1999         sv_insert(lsv, lvoff, lvlen, utf8, len);
2000         Safefree(utf8);
2001     }
2002     else {
2003         sv_insert(lsv, lvoff, lvlen, tmps, len);
2004         LvTARGLEN(sv) = len;
2005     }
2006
2007
2008     return 0;
2009 }
2010
2011 int
2012 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2013 {
2014     dVAR;
2015     PERL_UNUSED_ARG(sv);
2016     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2017     return 0;
2018 }
2019
2020 int
2021 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2022 {
2023     dVAR;
2024     PERL_UNUSED_ARG(sv);
2025     /* update taint status */
2026     if (PL_tainted)
2027         mg->mg_len |= 1;
2028     else
2029         mg->mg_len &= ~1;
2030     return 0;
2031 }
2032
2033 int
2034 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2035 {
2036     SV * const lsv = LvTARG(sv);
2037     PERL_UNUSED_ARG(mg);
2038
2039     if (lsv)
2040         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2041     else
2042         SvOK_off(sv);
2043
2044     return 0;
2045 }
2046
2047 int
2048 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2049 {
2050     PERL_UNUSED_ARG(mg);
2051     do_vecset(sv);      /* XXX slurp this routine */
2052     return 0;
2053 }
2054
2055 int
2056 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2057 {
2058     dVAR;
2059     SV *targ = NULL;
2060     if (LvTARGLEN(sv)) {
2061         if (mg->mg_obj) {
2062             SV * const ahv = LvTARG(sv);
2063             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2064             if (he)
2065                 targ = HeVAL(he);
2066         }
2067         else {
2068             AV* const av = (AV*)LvTARG(sv);
2069             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2070                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2071         }
2072         if (targ && (targ != &PL_sv_undef)) {
2073             /* somebody else defined it for us */
2074             SvREFCNT_dec(LvTARG(sv));
2075             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2076             LvTARGLEN(sv) = 0;
2077             SvREFCNT_dec(mg->mg_obj);
2078             mg->mg_obj = NULL;
2079             mg->mg_flags &= ~MGf_REFCOUNTED;
2080         }
2081     }
2082     else
2083         targ = LvTARG(sv);
2084     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2085     return 0;
2086 }
2087
2088 int
2089 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2090 {
2091     PERL_UNUSED_ARG(mg);
2092     if (LvTARGLEN(sv))
2093         vivify_defelem(sv);
2094     if (LvTARG(sv)) {
2095         sv_setsv(LvTARG(sv), sv);
2096         SvSETMAGIC(LvTARG(sv));
2097     }
2098     return 0;
2099 }
2100
2101 void
2102 Perl_vivify_defelem(pTHX_ SV *sv)
2103 {
2104     dVAR;
2105     MAGIC *mg;
2106     SV *value = NULL;
2107
2108     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2109         return;
2110     if (mg->mg_obj) {
2111         SV * const ahv = LvTARG(sv);
2112         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2113         if (he)
2114             value = HeVAL(he);
2115         if (!value || value == &PL_sv_undef)
2116             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2117     }
2118     else {
2119         AV* const av = (AV*)LvTARG(sv);
2120         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2121             LvTARG(sv) = NULL;  /* array can't be extended */
2122         else {
2123             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2124             if (!svp || (value = *svp) == &PL_sv_undef)
2125                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2126         }
2127     }
2128     SvREFCNT_inc_simple_void(value);
2129     SvREFCNT_dec(LvTARG(sv));
2130     LvTARG(sv) = value;
2131     LvTARGLEN(sv) = 0;
2132     SvREFCNT_dec(mg->mg_obj);
2133     mg->mg_obj = NULL;
2134     mg->mg_flags &= ~MGf_REFCOUNTED;
2135 }
2136
2137 int
2138 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2139 {
2140     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2141 }
2142
2143 int
2144 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2145 {
2146     PERL_UNUSED_CONTEXT;
2147     mg->mg_len = -1;
2148     SvSCREAM_off(sv);
2149     return 0;
2150 }
2151
2152 int
2153 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2154 {
2155     PERL_UNUSED_ARG(mg);
2156     sv_unmagic(sv, PERL_MAGIC_bm);
2157     SvTAIL_off(sv);
2158     SvVALID_off(sv);
2159     return 0;
2160 }
2161
2162 int
2163 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2164 {
2165     PERL_UNUSED_ARG(mg);
2166     sv_unmagic(sv, PERL_MAGIC_fm);
2167     SvCOMPILED_off(sv);
2168     return 0;
2169 }
2170
2171 int
2172 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2173 {
2174     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2175
2176     if (uf && uf->uf_set)
2177         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2178     return 0;
2179 }
2180
2181 int
2182 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2183 {
2184     PERL_UNUSED_ARG(mg);
2185     sv_unmagic(sv, PERL_MAGIC_qr);
2186     return 0;
2187 }
2188
2189 int
2190 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2191 {
2192     dVAR;
2193     regexp * const re = (regexp *)mg->mg_obj;
2194     PERL_UNUSED_ARG(sv);
2195
2196     ReREFCNT_dec(re);
2197     return 0;
2198 }
2199
2200 #ifdef USE_LOCALE_COLLATE
2201 int
2202 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2203 {
2204     /*
2205      * RenE<eacute> Descartes said "I think not."
2206      * and vanished with a faint plop.
2207      */
2208     PERL_UNUSED_CONTEXT;
2209     PERL_UNUSED_ARG(sv);
2210     if (mg->mg_ptr) {
2211         Safefree(mg->mg_ptr);
2212         mg->mg_ptr = NULL;
2213         mg->mg_len = -1;
2214     }
2215     return 0;
2216 }
2217 #endif /* USE_LOCALE_COLLATE */
2218
2219 /* Just clear the UTF-8 cache data. */
2220 int
2221 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2222 {
2223     PERL_UNUSED_CONTEXT;
2224     PERL_UNUSED_ARG(sv);
2225     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2226     mg->mg_ptr = NULL;
2227     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2228     return 0;
2229 }
2230
2231 int
2232 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2233 {
2234     dVAR;
2235     register const char *s;
2236     register I32 paren;
2237     register const REGEXP * rx;
2238     const char * const remaining = mg->mg_ptr + 1;
2239     I32 i;
2240     STRLEN len;
2241
2242     switch (*mg->mg_ptr) {
2243     case '\015': /* $^MATCH */
2244       if (strEQ(remaining, "ATCH"))
2245           goto do_match;
2246     case '`': /* ${^PREMATCH} caught below */
2247       do_prematch:
2248       paren = RX_BUFF_IDX_PREMATCH;
2249       goto setparen;
2250     case '\'': /* ${^POSTMATCH} caught below */
2251       do_postmatch:
2252       paren = RX_BUFF_IDX_POSTMATCH;
2253       goto setparen;
2254     case '&':
2255       do_match:
2256       paren = RX_BUFF_IDX_FULLMATCH;
2257       goto setparen;
2258     case '1': case '2': case '3': case '4':
2259     case '5': case '6': case '7': case '8': case '9':
2260       paren = atoi(mg->mg_ptr);
2261       setparen:
2262         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2263             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2264             break;
2265         } else {
2266             /* Croak with a READONLY error when a numbered match var is
2267              * set without a previous pattern match. Unless it's C<local $1>
2268              */
2269             if (!PL_localizing) {
2270                 Perl_croak(aTHX_ PL_no_modify);
2271             }
2272         }
2273     case '\001':        /* ^A */
2274         sv_setsv(PL_bodytarget, sv);
2275         break;
2276     case '\003':        /* ^C */
2277         PL_minus_c = (bool)SvIV(sv);
2278         break;
2279
2280     case '\004':        /* ^D */
2281 #ifdef DEBUGGING
2282         s = SvPV_nolen_const(sv);
2283         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2284         DEBUG_x(dump_all());
2285 #else
2286         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2287 #endif
2288         break;
2289     case '\005':  /* ^E */
2290         if (*(mg->mg_ptr+1) == '\0') {
2291 #ifdef MACOS_TRADITIONAL
2292             gMacPerl_OSErr = SvIV(sv);
2293 #else
2294 #  ifdef VMS
2295             set_vaxc_errno(SvIV(sv));
2296 #  else
2297 #    ifdef WIN32
2298             SetLastError( SvIV(sv) );
2299 #    else
2300 #      ifdef OS2
2301             os2_setsyserrno(SvIV(sv));
2302 #      else
2303             /* will anyone ever use this? */
2304             SETERRNO(SvIV(sv), 4);
2305 #      endif
2306 #    endif
2307 #  endif
2308 #endif
2309         }
2310         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2311             if (PL_encoding)
2312                 SvREFCNT_dec(PL_encoding);
2313             if (SvOK(sv) || SvGMAGICAL(sv)) {
2314                 PL_encoding = newSVsv(sv);
2315             }
2316             else {
2317                 PL_encoding = NULL;
2318             }
2319         }
2320         break;
2321     case '\006':        /* ^F */
2322         PL_maxsysfd = SvIV(sv);
2323         break;
2324     case '\010':        /* ^H */
2325         PL_hints = SvIV(sv);
2326         break;
2327     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2328         Safefree(PL_inplace);
2329         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2330         break;
2331     case '\017':        /* ^O */
2332         if (*(mg->mg_ptr+1) == '\0') {
2333             Safefree(PL_osname);
2334             PL_osname = NULL;
2335             if (SvOK(sv)) {
2336                 TAINT_PROPER("assigning to $^O");
2337                 PL_osname = savesvpv(sv);
2338             }
2339         }
2340         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2341             STRLEN len;
2342             const char *const start = SvPV(sv, len);
2343             const char *out = (const char*)memchr(start, '\0', len);
2344             SV *tmp;
2345             struct refcounted_he *tmp_he;
2346
2347
2348             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2349             PL_hints
2350                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2351
2352             /* Opening for input is more common than opening for output, so
2353                ensure that hints for input are sooner on linked list.  */
2354             tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2355                              : newSVpvs(""));
2356             SvFLAGS(tmp) |= SvUTF8(sv);
2357
2358             tmp_he
2359                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2360                                          sv_2mortal(newSVpvs("open>")), tmp);
2361
2362             /* The UTF-8 setting is carried over  */
2363             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2364
2365             PL_compiling.cop_hints_hash
2366                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2367                                          sv_2mortal(newSVpvs("open<")), tmp);
2368         }
2369         break;
2370     case '\020':        /* ^P */
2371       if (*remaining == '\0') { /* ^P */
2372           PL_perldb = SvIV(sv);
2373           if (PL_perldb && !PL_DBsingle)
2374               init_debugger();
2375           break;
2376       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2377           goto do_prematch;
2378       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2379           goto do_postmatch;
2380       }
2381     case '\024':        /* ^T */
2382 #ifdef BIG_TIME
2383         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2384 #else
2385         PL_basetime = (Time_t)SvIV(sv);
2386 #endif
2387         break;
2388     case '\025':        /* ^UTF8CACHE */
2389          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2390              PL_utf8cache = (signed char) sv_2iv(sv);
2391          }
2392          break;
2393     case '\027':        /* ^W & $^WARNING_BITS */
2394         if (*(mg->mg_ptr+1) == '\0') {
2395             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2396                 i = SvIV(sv);
2397                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2398                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2399             }
2400         }
2401         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2402             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2403                 if (!SvPOK(sv) && PL_localizing) {
2404                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2405                     PL_compiling.cop_warnings = pWARN_NONE;
2406                     break;
2407                 }
2408                 {
2409                     STRLEN len, i;
2410                     int accumulate = 0 ;
2411                     int any_fatals = 0 ;
2412                     const char * const ptr = SvPV_const(sv, len) ;
2413                     for (i = 0 ; i < len ; ++i) {
2414                         accumulate |= ptr[i] ;
2415                         any_fatals |= (ptr[i] & 0xAA) ;
2416                     }
2417                     if (!accumulate) {
2418                         if (!specialWARN(PL_compiling.cop_warnings))
2419                             PerlMemShared_free(PL_compiling.cop_warnings);
2420                         PL_compiling.cop_warnings = pWARN_NONE;
2421                     }
2422                     /* Yuck. I can't see how to abstract this:  */
2423                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2424                                        WARN_ALL) && !any_fatals) {
2425                         if (!specialWARN(PL_compiling.cop_warnings))
2426                             PerlMemShared_free(PL_compiling.cop_warnings);
2427                         PL_compiling.cop_warnings = pWARN_ALL;
2428                         PL_dowarn |= G_WARN_ONCE ;
2429                     }
2430                     else {
2431                         STRLEN len;
2432                         const char *const p = SvPV_const(sv, len);
2433
2434                         PL_compiling.cop_warnings
2435                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2436                                                          p, len);
2437
2438                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2439                             PL_dowarn |= G_WARN_ONCE ;
2440                     }
2441
2442                 }
2443             }
2444         }
2445         break;
2446     case '.':
2447         if (PL_localizing) {
2448             if (PL_localizing == 1)
2449                 SAVESPTR(PL_last_in_gv);
2450         }
2451         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2452             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2453         break;
2454     case '^':
2455         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2456         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2457         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2458         break;
2459     case '~':
2460         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2461         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2462         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2463         break;
2464     case '=':
2465         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2466         break;
2467     case '-':
2468         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2469         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2470             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2471         break;
2472     case '%':
2473         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2474         break;
2475     case '|':
2476         {
2477             IO * const io = GvIOp(PL_defoutgv);
2478             if(!io)
2479               break;
2480             if ((SvIV(sv)) == 0)
2481                 IoFLAGS(io) &= ~IOf_FLUSH;
2482             else {
2483                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2484                     PerlIO *ofp = IoOFP(io);
2485                     if (ofp)
2486                         (void)PerlIO_flush(ofp);
2487                     IoFLAGS(io) |= IOf_FLUSH;
2488                 }
2489             }
2490         }
2491         break;
2492     case '/':
2493         SvREFCNT_dec(PL_rs);
2494         PL_rs = newSVsv(sv);
2495         break;
2496     case '\\':
2497         if (PL_ors_sv)
2498             SvREFCNT_dec(PL_ors_sv);
2499         if (SvOK(sv) || SvGMAGICAL(sv)) {
2500             PL_ors_sv = newSVsv(sv);
2501         }
2502         else {
2503             PL_ors_sv = NULL;
2504         }
2505         break;
2506     case ',':
2507         if (PL_ofs_sv)
2508             SvREFCNT_dec(PL_ofs_sv);
2509         if (SvOK(sv) || SvGMAGICAL(sv)) {
2510             PL_ofs_sv = newSVsv(sv);
2511         }
2512         else {
2513             PL_ofs_sv = NULL;
2514         }
2515         break;
2516     case '[':
2517         CopARYBASE_set(&PL_compiling, SvIV(sv));
2518         break;
2519     case '?':
2520 #ifdef COMPLEX_STATUS
2521         if (PL_localizing == 2) {
2522             PL_statusvalue = LvTARGOFF(sv);
2523             PL_statusvalue_vms = LvTARGLEN(sv);
2524         }
2525         else
2526 #endif
2527 #ifdef VMSISH_STATUS
2528         if (VMSISH_STATUS)
2529             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2530         else
2531 #endif
2532             STATUS_UNIX_EXIT_SET(SvIV(sv));
2533         break;
2534     case '!':
2535         {
2536 #ifdef VMS
2537 #   define PERL_VMS_BANG vaxc$errno
2538 #else
2539 #   define PERL_VMS_BANG 0
2540 #endif
2541         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2542                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2543         }
2544         break;
2545     case '<':
2546         PL_uid = SvIV(sv);
2547         if (PL_delaymagic) {
2548             PL_delaymagic |= DM_RUID;
2549             break;                              /* don't do magic till later */
2550         }
2551 #ifdef HAS_SETRUID
2552         (void)setruid((Uid_t)PL_uid);
2553 #else
2554 #ifdef HAS_SETREUID
2555         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2556 #else
2557 #ifdef HAS_SETRESUID
2558       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2559 #else
2560         if (PL_uid == PL_euid) {                /* special case $< = $> */
2561 #ifdef PERL_DARWIN
2562             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2563             if (PL_uid != 0 && PerlProc_getuid() == 0)
2564                 (void)PerlProc_setuid(0);
2565 #endif
2566             (void)PerlProc_setuid(PL_uid);
2567         } else {
2568             PL_uid = PerlProc_getuid();
2569             Perl_croak(aTHX_ "setruid() not implemented");
2570         }
2571 #endif
2572 #endif
2573 #endif
2574         PL_uid = PerlProc_getuid();
2575         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2576         break;
2577     case '>':
2578         PL_euid = SvIV(sv);
2579         if (PL_delaymagic) {
2580             PL_delaymagic |= DM_EUID;
2581             break;                              /* don't do magic till later */
2582         }
2583 #ifdef HAS_SETEUID
2584         (void)seteuid((Uid_t)PL_euid);
2585 #else
2586 #ifdef HAS_SETREUID
2587         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2588 #else
2589 #ifdef HAS_SETRESUID
2590         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2591 #else
2592         if (PL_euid == PL_uid)          /* special case $> = $< */
2593             PerlProc_setuid(PL_euid);
2594         else {
2595             PL_euid = PerlProc_geteuid();
2596             Perl_croak(aTHX_ "seteuid() not implemented");
2597         }
2598 #endif
2599 #endif
2600 #endif
2601         PL_euid = PerlProc_geteuid();
2602         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2603         break;
2604     case '(':
2605         PL_gid = SvIV(sv);
2606         if (PL_delaymagic) {
2607             PL_delaymagic |= DM_RGID;
2608             break;                              /* don't do magic till later */
2609         }
2610 #ifdef HAS_SETRGID
2611         (void)setrgid((Gid_t)PL_gid);
2612 #else
2613 #ifdef HAS_SETREGID
2614         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2615 #else
2616 #ifdef HAS_SETRESGID
2617       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2618 #else
2619         if (PL_gid == PL_egid)                  /* special case $( = $) */
2620             (void)PerlProc_setgid(PL_gid);
2621         else {
2622             PL_gid = PerlProc_getgid();
2623             Perl_croak(aTHX_ "setrgid() not implemented");
2624         }
2625 #endif
2626 #endif
2627 #endif
2628         PL_gid = PerlProc_getgid();
2629         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2630         break;
2631     case ')':
2632 #ifdef HAS_SETGROUPS
2633         {
2634             const char *p = SvPV_const(sv, len);
2635             Groups_t *gary = NULL;
2636
2637             while (isSPACE(*p))
2638                 ++p;
2639             PL_egid = Atol(p);
2640             for (i = 0; i < NGROUPS; ++i) {
2641                 while (*p && !isSPACE(*p))
2642                     ++p;
2643                 while (isSPACE(*p))
2644                     ++p;
2645                 if (!*p)
2646                     break;
2647                 if(!gary)
2648                     Newx(gary, i + 1, Groups_t);
2649                 else
2650                     Renew(gary, i + 1, Groups_t);
2651                 gary[i] = Atol(p);
2652             }
2653             if (i)
2654                 (void)setgroups(i, gary);
2655             Safefree(gary);
2656         }
2657 #else  /* HAS_SETGROUPS */
2658         PL_egid = SvIV(sv);
2659 #endif /* HAS_SETGROUPS */
2660         if (PL_delaymagic) {
2661             PL_delaymagic |= DM_EGID;
2662             break;                              /* don't do magic till later */
2663         }
2664 #ifdef HAS_SETEGID
2665         (void)setegid((Gid_t)PL_egid);
2666 #else
2667 #ifdef HAS_SETREGID
2668         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2669 #else
2670 #ifdef HAS_SETRESGID
2671         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2672 #else
2673         if (PL_egid == PL_gid)                  /* special case $) = $( */
2674             (void)PerlProc_setgid(PL_egid);
2675         else {
2676             PL_egid = PerlProc_getegid();
2677             Perl_croak(aTHX_ "setegid() not implemented");
2678         }
2679 #endif
2680 #endif
2681 #endif
2682         PL_egid = PerlProc_getegid();
2683         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2684         break;
2685     case ':':
2686         PL_chopset = SvPV_force(sv,len);
2687         break;
2688 #ifndef MACOS_TRADITIONAL
2689     case '0':
2690         LOCK_DOLLARZERO_MUTEX;
2691 #ifdef HAS_SETPROCTITLE
2692         /* The BSDs don't show the argv[] in ps(1) output, they
2693          * show a string from the process struct and provide
2694          * the setproctitle() routine to manipulate that. */
2695         if (PL_origalen != 1) {
2696             s = SvPV_const(sv, len);
2697 #   if __FreeBSD_version > 410001
2698             /* The leading "-" removes the "perl: " prefix,
2699              * but not the "(perl) suffix from the ps(1)
2700              * output, because that's what ps(1) shows if the
2701              * argv[] is modified. */
2702             setproctitle("-%s", s);
2703 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2704             /* This doesn't really work if you assume that
2705              * $0 = 'foobar'; will wipe out 'perl' from the $0
2706              * because in ps(1) output the result will be like
2707              * sprintf("perl: %s (perl)", s)
2708              * I guess this is a security feature:
2709              * one (a user process) cannot get rid of the original name.
2710              * --jhi */
2711             setproctitle("%s", s);
2712 #   endif
2713         }
2714 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2715         if (PL_origalen != 1) {
2716              union pstun un;
2717              s = SvPV_const(sv, len);
2718              un.pst_command = (char *)s;
2719              pstat(PSTAT_SETCMD, un, len, 0, 0);
2720         }
2721 #else
2722         if (PL_origalen > 1) {
2723             /* PL_origalen is set in perl_parse(). */
2724             s = SvPV_force(sv,len);
2725             if (len >= (STRLEN)PL_origalen-1) {
2726                 /* Longer than original, will be truncated. We assume that
2727                  * PL_origalen bytes are available. */
2728                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2729             }
2730             else {
2731                 /* Shorter than original, will be padded. */
2732 #ifdef PERL_DARWIN
2733                 /* Special case for Mac OS X: see [perl #38868] */
2734                 const int pad = 0;
2735 #else
2736                 /* Is the space counterintuitive?  Yes.
2737                  * (You were expecting \0?)
2738                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2739                  * --jhi */
2740                 const int pad = ' ';
2741 #endif
2742                 Copy(s, PL_origargv[0], len, char);
2743                 PL_origargv[0][len] = 0;
2744                 memset(PL_origargv[0] + len + 1,
2745                        pad,  PL_origalen - len - 1);
2746             }
2747             PL_origargv[0][PL_origalen-1] = 0;
2748             for (i = 1; i < PL_origargc; i++)
2749                 PL_origargv[i] = 0;
2750         }
2751 #endif
2752         UNLOCK_DOLLARZERO_MUTEX;
2753         break;
2754 #endif
2755     }
2756     return 0;
2757 }
2758
2759 I32
2760 Perl_whichsig(pTHX_ const char *sig)
2761 {
2762     register char* const* sigv;
2763     PERL_UNUSED_CONTEXT;
2764
2765     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2766         if (strEQ(sig,*sigv))
2767             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2768 #ifdef SIGCLD
2769     if (strEQ(sig,"CHLD"))
2770         return SIGCLD;
2771 #endif
2772 #ifdef SIGCHLD
2773     if (strEQ(sig,"CLD"))
2774         return SIGCHLD;
2775 #endif
2776     return -1;
2777 }
2778
2779 Signal_t
2780 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2781 Perl_sighandler(int sig, ...)
2782 #else
2783 Perl_sighandler(int sig)
2784 #endif
2785 {
2786 #ifdef PERL_GET_SIG_CONTEXT
2787     dTHXa(PERL_GET_SIG_CONTEXT);
2788 #else
2789     dTHX;
2790 #endif
2791     dSP;
2792     GV *gv = NULL;
2793     SV *sv = NULL;
2794     SV * const tSv = PL_Sv;
2795     CV *cv = NULL;
2796     OP *myop = PL_op;
2797     U32 flags = 0;
2798     XPV * const tXpv = PL_Xpv;
2799
2800     if (PL_savestack_ix + 15 <= PL_savestack_max)
2801         flags |= 1;
2802     if (PL_markstack_ptr < PL_markstack_max - 2)
2803         flags |= 4;
2804     if (PL_scopestack_ix < PL_scopestack_max - 3)
2805         flags |= 16;
2806
2807     if (!PL_psig_ptr[sig]) {
2808                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2809                                  PL_sig_name[sig]);
2810                 exit(sig);
2811         }
2812
2813     /* Max number of items pushed there is 3*n or 4. We cannot fix
2814        infinity, so we fix 4 (in fact 5): */
2815     if (flags & 1) {
2816         PL_savestack_ix += 5;           /* Protect save in progress. */
2817         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2818     }
2819     if (flags & 4)
2820         PL_markstack_ptr++;             /* Protect mark. */
2821     if (flags & 16)
2822         PL_scopestack_ix += 1;
2823     /* sv_2cv is too complicated, try a simpler variant first: */
2824     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2825         || SvTYPE(cv) != SVt_PVCV) {
2826         HV *st;
2827         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2828     }
2829
2830     if (!cv || !CvROOT(cv)) {
2831         if (ckWARN(WARN_SIGNAL))
2832             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2833                 PL_sig_name[sig], (gv ? GvENAME(gv)
2834                                 : ((cv && CvGV(cv))
2835                                    ? GvENAME(CvGV(cv))
2836                                    : "__ANON__")));
2837         goto cleanup;
2838     }
2839
2840     if(PL_psig_name[sig]) {
2841         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2842         flags |= 64;
2843 #if !defined(PERL_IMPLICIT_CONTEXT)
2844         PL_sig_sv = sv;
2845 #endif
2846     } else {
2847         sv = sv_newmortal();
2848         sv_setpv(sv,PL_sig_name[sig]);
2849     }
2850
2851     PUSHSTACKi(PERLSI_SIGNAL);
2852     PUSHMARK(SP);
2853     PUSHs(sv);
2854 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2855     {
2856          struct sigaction oact;
2857
2858          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2859               siginfo_t *sip;
2860               va_list args;
2861
2862               va_start(args, sig);
2863               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2864               if (sip) {
2865                    HV *sih = newHV();
2866                    SV *rv  = newRV_noinc((SV*)sih);
2867                    /* The siginfo fields signo, code, errno, pid, uid,
2868                     * addr, status, and band are defined by POSIX/SUSv3. */
2869                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2870                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2871 #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. */
2872                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2873                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2874                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2875                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2876                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2877                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2878 #endif
2879                    EXTEND(SP, 2);
2880                    PUSHs((SV*)rv);
2881                    PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2882               }
2883
2884               va_end(args);
2885          }
2886     }
2887 #endif
2888     PUTBACK;
2889
2890     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2891
2892     POPSTACK;
2893     if (SvTRUE(ERRSV)) {
2894 #ifndef PERL_MICRO
2895 #ifdef HAS_SIGPROCMASK
2896         /* Handler "died", for example to get out of a restart-able read().
2897          * Before we re-do that on its behalf re-enable the signal which was
2898          * blocked by the system when we entered.
2899          */
2900         sigset_t set;
2901         sigemptyset(&set);
2902         sigaddset(&set,sig);
2903         sigprocmask(SIG_UNBLOCK, &set, NULL);
2904 #else
2905         /* Not clear if this will work */
2906         (void)rsignal(sig, SIG_IGN);
2907         (void)rsignal(sig, PL_csighandlerp);
2908 #endif
2909 #endif /* !PERL_MICRO */
2910         Perl_die(aTHX_ NULL);
2911     }
2912 cleanup:
2913     if (flags & 1)
2914         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2915     if (flags & 4)
2916         PL_markstack_ptr--;
2917     if (flags & 16)
2918         PL_scopestack_ix -= 1;
2919     if (flags & 64)
2920         SvREFCNT_dec(sv);
2921     PL_op = myop;                       /* Apparently not needed... */
2922
2923     PL_Sv = tSv;                        /* Restore global temporaries. */
2924     PL_Xpv = tXpv;
2925     return;
2926 }
2927
2928
2929 static void
2930 S_restore_magic(pTHX_ const void *p)
2931 {
2932     dVAR;
2933     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2934     SV* const sv = mgs->mgs_sv;
2935
2936     if (!sv)
2937         return;
2938
2939     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2940     {
2941 #ifdef PERL_OLD_COPY_ON_WRITE
2942         /* While magic was saved (and off) sv_setsv may well have seen
2943            this SV as a prime candidate for COW.  */
2944         if (SvIsCOW(sv))
2945             sv_force_normal_flags(sv, 0);
2946 #endif
2947
2948         if (mgs->mgs_flags)
2949             SvFLAGS(sv) |= mgs->mgs_flags;
2950         else
2951             mg_magical(sv);
2952         if (SvGMAGICAL(sv)) {
2953             /* downgrade public flags to private,
2954                and discard any other private flags */
2955
2956             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2957             if (pubflags) {
2958                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2959                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2960             }
2961         }
2962     }
2963
2964     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2965
2966     /* If we're still on top of the stack, pop us off.  (That condition
2967      * will be satisfied if restore_magic was called explicitly, but *not*
2968      * if it's being called via leave_scope.)
2969      * The reason for doing this is that otherwise, things like sv_2cv()
2970      * may leave alloc gunk on the savestack, and some code
2971      * (e.g. sighandler) doesn't expect that...
2972      */
2973     if (PL_savestack_ix == mgs->mgs_ss_ix)
2974     {
2975         I32 popval = SSPOPINT;
2976         assert(popval == SAVEt_DESTRUCTOR_X);
2977         PL_savestack_ix -= 2;
2978         popval = SSPOPINT;
2979         assert(popval == SAVEt_ALLOC);
2980         popval = SSPOPINT;
2981         PL_savestack_ix -= popval;
2982     }
2983
2984 }
2985
2986 static void
2987 S_unwind_handler_stack(pTHX_ const void *p)
2988 {
2989     dVAR;
2990     const U32 flags = *(const U32*)p;
2991
2992     if (flags & 1)
2993         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2994 #if !defined(PERL_IMPLICIT_CONTEXT)
2995     if (flags & 64)
2996         SvREFCNT_dec(PL_sig_sv);
2997 #endif
2998 }
2999
3000 /*
3001 =for apidoc magic_sethint
3002
3003 Triggered by a store to %^H, records the key/value pair to
3004 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3005 anything that would need a deep copy.  Maybe we should warn if we find a
3006 reference.
3007
3008 =cut
3009 */
3010 int
3011 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3012 {
3013     dVAR;
3014     assert(mg->mg_len == HEf_SVKEY);
3015
3016     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3017        an alternative leaf in there, with PL_compiling.cop_hints being used if
3018        it's NULL. If needed for threads, the alternative could lock a mutex,
3019        or take other more complex action.  */
3020
3021     /* Something changed in %^H, so it will need to be restored on scope exit.
3022        Doing this here saves a lot of doing it manually in perl code (and
3023        forgetting to do it, and consequent subtle errors.  */
3024     PL_hints |= HINT_LOCALIZE_HH;
3025     PL_compiling.cop_hints_hash
3026         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3027                                  (SV *)mg->mg_ptr, sv);
3028     return 0;
3029 }
3030
3031 /*
3032 =for apidoc magic_sethint
3033
3034 Triggered by a delete from %^H, records the key to
3035 C<PL_compiling.cop_hints_hash>.
3036
3037 =cut
3038 */
3039 int
3040 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3041 {
3042     dVAR;
3043     PERL_UNUSED_ARG(sv);
3044
3045     assert(mg->mg_len == HEf_SVKEY);
3046
3047     PERL_UNUSED_ARG(sv);
3048
3049     PL_hints |= HINT_LOCALIZE_HH;
3050     PL_compiling.cop_hints_hash
3051         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3052                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
3053     return 0;
3054 }
3055
3056 /*
3057  * Local variables:
3058  * c-indentation-style: bsd
3059  * c-basic-offset: 4
3060  * indent-tabs-mode: t
3061  * End:
3062  *
3063  * ex: set ts=8 sts=4 sw=4 noet:
3064  */