mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * "Sam sat on the ground and put his head in his hands.  'I wish I had never
  13  * come here, and I don't want to see no more magic,' he said, and fell silent."
  14  */
  15
  16 /*
  17 =head1 Magical Functions
  18
  19 "Magic" is special data attached to SV structures in order to give them
  20 "magical" properties.  When any Perl code tries to read from, or assign to,
  21 an SV marked as magical, it calls the 'get' or 'set' function associated
  22 with that SV's magic. A get is called prior to reading an SV, in order to
  23 give it a chance to update its internal value (get on $. writes the line
  24 number of the last read filehandle into to the SV's IV slot), while
  25 set is called after an SV has been written to, in order to allow it to make
  26 use of its changed value (set on $/ copies the SV's new value to the
  27 PL_rs global variable).
  28
  29 Magic is implemented as a linked list of MAGIC structures attached to the
  30 SV. Each MAGIC struct holds the type of the magic, a pointer to an array
  31 of functions that implement the get(), set(), length() etc functions,
  32 plus space for some flags and pointers. For example, a tied variable has
  33 a MAGIC structure that contains a pointer to the object associated with the
  34 tie.
  35
  36 */
  37
  38 #include "EXTERN.h"
  39 #define PERL_IN_MG_C
  40 #include "perl.h"
  41
  42 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
  43 #  ifdef I_GRP
  44 #    include <grp.h>
  45 #  endif
  46 #endif
  47
  48 #if defined(HAS_SETGROUPS)
  49 #  ifndef NGROUPS
  50 #    define NGROUPS 32
  51 #  endif
  52 #endif
  53
  54 #ifdef __hpux
  55 #  include <sys/pstat.h>
  56 #endif
  57
  58 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
  59 Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
  60 #else
  61 Signal_t Perl_csighandler(int sig);
  62 #endif
  63
  64 #ifdef __Lynx__
  65 /* Missing protos on LynxOS */
  66 void setruid(uid_t id);
  67 void seteuid(uid_t id);
  68 void setrgid(uid_t id);
  69 void setegid(uid_t id);
  70 #endif
  71
  72 /*
  73  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  74  */
  75
  76 struct magic_state {
  77     SV* mgs_sv;
  78     U32 mgs_flags;
  79     I32 mgs_ss_ix;
  80 };
  81 /* MGS is typedef'ed to struct magic_state in perl.h */
  82
  83 STATIC void
  84 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
  85 {
  86     dVAR;
  87     MGS* mgs;
  88     assert(SvMAGICAL(sv));
  89     /* Turning READONLY off for a copy-on-write scalar (including shared
  90        hash keys) is a bad idea.  */
  91     if (SvIsCOW(sv))
  92       sv_force_normal_flags(sv, 0);
  93
  94     SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
  95
  96     mgs = SSPTR(mgs_ix, MGS*);
  97     mgs->mgs_sv = sv;
  98     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  99     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
 100
 101     SvMAGICAL_off(sv);
 102     SvREADONLY_off(sv);
 103     if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
 104         /* No public flags are set, so promote any private flags to public.  */
 105         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 106     }
 107 }
 108
 109 /*
 110 =for apidoc mg_magical
 111
 112 Turns on the magical status of an SV.  See C<sv_magic>.
 113
 114 =cut
 115 */
 116
 117 void
 118 Perl_mg_magical(pTHX_ SV *sv)
 119 {
 120     const MAGIC* mg;
 121     PERL_UNUSED_CONTEXT;
 122     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 123         const MGVTBL* const vtbl = mg->mg_virtual;
 124         if (vtbl) {
 125             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
 126                 SvGMAGICAL_on(sv);
 127             if (vtbl->svt_set)
 128                 SvSMAGICAL_on(sv);
 129             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
 130                 SvRMAGICAL_on(sv);
 131         }
 132     }
 133 }
 134
 135
 136 /* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
 137
 138 STATIC bool
 139 S_is_container_magic(const MAGIC *mg)
 140 {
 141     switch (mg->mg_type) {
 142     case PERL_MAGIC_bm:
 143     case PERL_MAGIC_fm:
 144     case PERL_MAGIC_regex_global:
 145     case PERL_MAGIC_nkeys:
 146 #ifdef USE_LOCALE_COLLATE
 147     case PERL_MAGIC_collxfrm:
 148 #endif
 149     case PERL_MAGIC_qr:
 150     case PERL_MAGIC_taint:
 151     case PERL_MAGIC_vec:
 152     case PERL_MAGIC_vstring:
 153     case PERL_MAGIC_utf8:
 154     case PERL_MAGIC_substr:
 155     case PERL_MAGIC_defelem:
 156     case PERL_MAGIC_arylen:
 157     case PERL_MAGIC_pos:
 158     case PERL_MAGIC_backref:
 159     case PERL_MAGIC_arylen_p:
 160     case PERL_MAGIC_rhash:
 161     case PERL_MAGIC_symtab:
 162         return 0;
 163     default:
 164         return 1;
 165     }
 166 }
 167
 168 /*
 169 =for apidoc mg_get
 170
 171 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 172
 173 =cut
 174 */
 175
 176 int
 177 Perl_mg_get(pTHX_ SV *sv)
 178 {
 179     dVAR;
 180     const I32 mgs_ix = SSNEW(sizeof(MGS));
 181     const bool was_temp = (bool)SvTEMP(sv);
 182     int have_new = 0;
 183     MAGIC *newmg, *head, *cur, *mg;
 184     /* guard against sv having being freed midway by holding a private
 185        reference. */
 186
 187     /* sv_2mortal has this side effect of turning on the TEMP flag, which can
 188        cause the SV's buffer to get stolen (and maybe other stuff).
 189        So restore it.
 190     */
 191     sv_2mortal(SvREFCNT_inc_simple_NN(sv));
 192     if (!was_temp) {
 193         SvTEMP_off(sv);
 194     }
 195
 196     save_magic(mgs_ix, sv);
 197
 198     /* We must call svt_get(sv, mg) for each valid entry in the linked
 199        list of magic. svt_get() may delete the current entry, add new
 200        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 201
 202     newmg = cur = head = mg = SvMAGIC(sv);
 203     while (mg) {
 204         const MGVTBL * const vtbl = mg->mg_virtual;
 205
 206         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 207             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 208
 209             /* guard against magic having been deleted - eg FETCH calling
 210              * untie */
 211             if (!SvMAGIC(sv))
 212                 break;
 213
 214             /* Don't restore the flags for this entry if it was deleted. */
 215             if (mg->mg_flags & MGf_GSKIP)
 216                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
 217         }
 218
 219         mg = mg->mg_moremagic;
 220
 221         if (have_new) {
 222             /* Have we finished with the new entries we saw? Start again
 223                where we left off (unless there are more new entries). */
 224             if (mg == head) {
 225                 have_new = 0;
 226                 mg   = cur;
 227                 head = newmg;
 228             }
 229         }
 230
 231         /* Were any new entries added? */
 232         if (!have_new && (newmg = SvMAGIC(sv)) != head) {
 233             have_new = 1;
 234             cur = mg;
 235             mg  = newmg;
 236         }
 237     }
 238
 239     restore_magic(INT2PTR(void *, (IV)mgs_ix));
 240
 241     if (SvREFCNT(sv) == 1) {
 242         /* We hold the last reference to this SV, which implies that the
 243            SV was deleted as a side effect of the routines we called.  */
 244         SvOK_off(sv);
 245     }
 246     return 0;
 247 }
 248
 249 /*
 250 =for apidoc mg_set
 251
 252 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 253
 254 =cut
 255 */
 256
 257 int
 258 Perl_mg_set(pTHX_ SV *sv)
 259 {
 260     dVAR;
 261     const I32 mgs_ix = SSNEW(sizeof(MGS));
 262     MAGIC* mg;
 263     MAGIC* nextmg;
 264
 265     save_magic(mgs_ix, sv);
 266
 267     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 268         const MGVTBL* vtbl = mg->mg_virtual;
 269         nextmg = mg->mg_moremagic;      /* it may delete itself */
 270         if (mg->mg_flags & MGf_GSKIP) {
 271             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 272             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
 273         }
 274         if (PL_localizing == 2 && !S_is_container_magic(mg))
 275             continue;
 276         if (vtbl && vtbl->svt_set)
 277             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
 278     }
 279
 280     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 281     return 0;
 282 }
 283
 284 /*
 285 =for apidoc mg_length
 286
 287 Report on the SV's length.  See C<sv_magic>.
 288
 289 =cut
 290 */
 291
 292 U32
 293 Perl_mg_length(pTHX_ SV *sv)
 294 {
 295     dVAR;
 296     MAGIC* mg;
 297     STRLEN len;
 298
 299     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 300         const MGVTBL * const vtbl = mg->mg_virtual;
 301         if (vtbl && vtbl->svt_len) {
 302             const I32 mgs_ix = SSNEW(sizeof(MGS));
 303             save_magic(mgs_ix, sv);
 304             /* omit MGf_GSKIP -- not changed here */
 305             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 306             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 307             return len;
 308         }
 309     }
 310
 311     if (DO_UTF8(sv)) {
 312         const U8 *s = (U8*)SvPV_const(sv, len);
 313         len = utf8_length(s, s + len);
 314     }
 315     else
 316         (void)SvPV_const(sv, len);
 317     return len;
 318 }
 319
 320 I32
 321 Perl_mg_size(pTHX_ SV *sv)
 322 {
 323     MAGIC* mg;
 324
 325     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 326         const MGVTBL* const vtbl = mg->mg_virtual;
 327         if (vtbl && vtbl->svt_len) {
 328             const I32 mgs_ix = SSNEW(sizeof(MGS));
 329             I32 len;
 330             save_magic(mgs_ix, sv);
 331             /* omit MGf_GSKIP -- not changed here */
 332             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 333             restore_magic(INT2PTR(void*, (IV)mgs_ix));
 334             return len;
 335         }
 336     }
 337
 338     switch(SvTYPE(sv)) {
 339         case SVt_PVAV:
 340             return AvFILLp((AV *) sv); /* Fallback to non-tied array */
 341         case SVt_PVHV:
 342             /* FIXME */
 343         default:
 344             Perl_croak(aTHX_ "Size magic not implemented");
 345             break;
 346     }
 347     return 0;
 348 }
 349
 350 /*
 351 =for apidoc mg_clear
 352
 353 Clear something magical that the SV represents.  See C<sv_magic>.
 354
 355 =cut
 356 */
 357
 358 int
 359 Perl_mg_clear(pTHX_ SV *sv)
 360 {
 361     const I32 mgs_ix = SSNEW(sizeof(MGS));
 362     MAGIC* mg;
 363
 364     save_magic(mgs_ix, sv);
 365
 366     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 367         const MGVTBL* const vtbl = mg->mg_virtual;
 368         /* omit GSKIP -- never set here */
 369
 370         if (vtbl && vtbl->svt_clear)
 371             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 372     }
 373
 374     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 375     return 0;
 376 }
 377
 378 /*
 379 =for apidoc mg_find
 380
 381 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 382
 383 =cut
 384 */
 385
 386 MAGIC*
 387 Perl_mg_find(pTHX_ const SV *sv, int type)
 388 {
 389     PERL_UNUSED_CONTEXT;
 390     if (sv) {
 391         MAGIC *mg;
 392         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 393             if (mg->mg_type == type)
 394                 return mg;
 395         }
 396     }
 397     return NULL;
 398 }
 399
 400 /*
 401 =for apidoc mg_copy
 402
 403 Copies the magic from one SV to another.  See C<sv_magic>.
 404
 405 =cut
 406 */
 407
 408 int
 409 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 410 {
 411     int count = 0;
 412     MAGIC* mg;
 413     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 414         const MGVTBL* const vtbl = mg->mg_virtual;
 415         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 416             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 417         }
 418         else {
 419             const char type = mg->mg_type;
 420             if (isUPPER(type) && type != PERL_MAGIC_uvar) {
 421                 sv_magic(nsv,
 422                      (type == PERL_MAGIC_tied)
 423                         ? SvTIED_obj(sv, mg)
 424                         : (type == PERL_MAGIC_regdata && mg->mg_obj)
 425                             ? sv
 426                             : mg->mg_obj,
 427                      toLOWER(type), key, klen);
 428                 count++;
 429             }
 430         }
 431     }
 432     return count;
 433 }
 434
 435 /*
 436 =for apidoc mg_localize
 437
 438 Copy some of the magic from an existing SV to new localized version of
 439 that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
 440 doesn't (eg taint, pos).
 441
 442 =cut
 443 */
 444
 445 void
 446 Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
 447 {
 448     dVAR;
 449     MAGIC *mg;
 450     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 451         const MGVTBL* const vtbl = mg->mg_virtual;
 452         if (!S_is_container_magic(mg))
 453             continue;
 454
 455         if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
 456             (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
 457         else
 458             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 459                             mg->mg_ptr, mg->mg_len);
 460
 461         /* container types should remain read-only across localization */
 462         SvFLAGS(nsv) |= SvREADONLY(sv);
 463     }
 464
 465     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 466         SvFLAGS(nsv) |= SvMAGICAL(sv);
 467         PL_localizing = 1;
 468         SvSETMAGIC(nsv);
 469         PL_localizing = 0;
 470     }
 471 }
 472
 473 /*
 474 =for apidoc mg_free
 475
 476 Free any magic storage used by the SV.  See C<sv_magic>.
 477
 478 =cut
 479 */
 480
 481 int
 482 Perl_mg_free(pTHX_ SV *sv)
 483 {
 484     MAGIC* mg;
 485     MAGIC* moremagic;
 486     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 487         const MGVTBL* const vtbl = mg->mg_virtual;
 488         moremagic = mg->mg_moremagic;
 489         if (vtbl && vtbl->svt_free)
 490             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 491         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 492             if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 493                 Safefree(mg->mg_ptr);
 494             else if (mg->mg_len == HEf_SVKEY)
 495                 SvREFCNT_dec((SV*)mg->mg_ptr);
 496         }
 497         if (mg->mg_flags & MGf_REFCOUNTED)
 498             SvREFCNT_dec(mg->mg_obj);
 499         Safefree(mg);
 500     }
 501     SvMAGIC_set(sv, NULL);
 502     return 0;
 503 }
 504
 505 #include <signal.h>
 506
 507 U32
 508 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 509 {
 510     dVAR;
 511     PERL_UNUSED_ARG(sv);
 512
 513     if (PL_curpm) {
 514         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 515         if (rx) {
 516             if (mg->mg_obj) {                   /* @+ */
 517                 /* return the number possible */
 518                 return rx->nparens;
 519             } else {                            /* @- */
 520                 I32 paren = rx->lastparen;
 521
 522                 /* return the last filled */
 523                 while ( paren >= 0
 524                         && (rx->offs[paren].start == -1
 525                             || rx->offs[paren].end == -1) )
 526                     paren--;
 527                 return (U32)paren;
 528             }
 529         }
 530     }
 531
 532     return (U32)-1;
 533 }
 534
 535 int
 536 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 537 {
 538     dVAR;
 539     if (PL_curpm) {
 540         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 541         if (rx) {
 542             register const I32 paren = mg->mg_len;
 543             register I32 s;
 544             register I32 t;
 545             if (paren < 0)
 546                 return 0;
 547             if (paren <= (I32)rx->nparens &&
 548                 (s = rx->offs[paren].start) != -1 &&
 549                 (t = rx->offs[paren].end) != -1)
 550                 {
 551                     register I32 i;
 552                     if (mg->mg_obj)             /* @+ */
 553                         i = t;
 554                     else                        /* @- */
 555                         i = s;
 556
 557                     if (i > 0 && RX_MATCH_UTF8(rx)) {
 558                         const char * const b = rx->subbeg;
 559                         if (b)
 560                             i = utf8_length((U8*)b, (U8*)(b+i));
 561                     }
 562
 563                     sv_setiv(sv, i);
 564                 }
 565         }
 566     }
 567     return 0;
 568 }
 569
 570 int
 571 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 572 {
 573     PERL_UNUSED_ARG(sv);
 574     PERL_UNUSED_ARG(mg);
 575     Perl_croak(aTHX_ PL_no_modify);
 576     NORETURN_FUNCTION_END;
 577 }
 578
 579 U32
 580 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 581 {
 582     dVAR;
 583     register I32 paren;
 584     register I32 i;
 585     register const REGEXP * rx;
 586     const char * const remaining = mg->mg_ptr + 1;
 587
 588     switch (*mg->mg_ptr) {
 589     case '\020':
 590       if (*remaining == '\0') { /* ^P */
 591           break;
 592       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
 593           goto do_prematch;
 594       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
 595           goto do_postmatch;
 596       }
 597       break;
 598     case '\015': /* $^MATCH */
 599         if (strEQ(remaining, "ATCH")) {
 600         goto do_match;
 601     } else {
 602         break;
 603     }
 604     case '`':
 605       do_prematch:
 606       paren = RX_BUFF_IDX_PREMATCH;
 607       goto maybegetparen;
 608     case '\'':
 609       do_postmatch:
 610       paren = RX_BUFF_IDX_POSTMATCH;
 611       goto maybegetparen;
 612     case '&':
 613       do_match:
 614       paren = RX_BUFF_IDX_FULLMATCH;
 615       goto maybegetparen;
 616     case '1': case '2': case '3': case '4':
 617     case '5': case '6': case '7': case '8': case '9':
 618       paren = atoi(mg->mg_ptr);
 619     maybegetparen:
 620         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 621       getparen:
 622         i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
 623
 624                 if (i < 0)
 625                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 626                 return i;
 627         } else {
 628                 if (ckWARN(WARN_UNINITIALIZED))
 629                     report_uninit(sv);
 630                 return 0;
 631         }
 632     case '+':
 633         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 634             paren = rx->lastparen;
 635             if (paren)
 636                 goto getparen;
 637         }
 638         return 0;
 639     case '\016': /* ^N */
 640         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 641             paren = rx->lastcloseparen;
 642             if (paren)
 643                 goto getparen;
 644         }
 645         return 0;
 646     }
 647     magic_get(sv,mg);
 648     if (!SvPOK(sv) && SvNIOK(sv)) {
 649         sv_2pv(sv, 0);
 650     }
 651     if (SvPOK(sv))
 652         return SvCUR(sv);
 653     return 0;
 654 }
 655
 656 #define SvRTRIM(sv) STMT_START { \
 657     if (SvPOK(sv)) { \
 658         STRLEN len = SvCUR(sv); \
 659         char * const p = SvPVX(sv); \
 660         while (len > 0 && isSPACE(p[len-1])) \
 661            --len; \
 662         SvCUR_set(sv, len); \
 663         p[len] = '\0'; \
 664     } \
 665 } STMT_END
 666
 667 void
 668 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
 669 {
 670     if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
 671         sv_setsv(sv, &PL_sv_undef);
 672     else {
 673         sv_setpvs(sv, "");
 674         SvUTF8_off(sv);
 675         if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
 676             SV *const value = Perl_refcounted_he_fetch(aTHX_
 677                                                        c->cop_hints_hash,
 678                                                        0, "open<", 5, 0, 0);
 679             assert(value);
 680             sv_catsv(sv, value);
 681         }
 682         sv_catpvs(sv, "\0");
 683         if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
 684             SV *const value = Perl_refcounted_he_fetch(aTHX_
 685                                                        c->cop_hints_hash,
 686                                                        0, "open>", 5, 0, 0);
 687             assert(value);
 688             sv_catsv(sv, value);
 689         }
 690     }
 691 }
 692
 693 int
 694 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 695 {
 696     dVAR;
 697     register I32 paren;
 698     register char *s = NULL;
 699     register REGEXP *rx;
 700     const char * const remaining = mg->mg_ptr + 1;
 701     const char nextchar = *remaining;
 702
 703     switch (*mg->mg_ptr) {
 704     case '\001':                /* ^A */
 705         sv_setsv(sv, PL_bodytarget);
 706         break;
 707     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 708         if (nextchar == '\0') {
 709             sv_setiv(sv, (IV)PL_minus_c);
 710         }
 711         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 712             sv_setiv(sv, (IV)STATUS_NATIVE);
 713         }
 714         break;
 715
 716     case '\004':                /* ^D */
 717         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 718         break;
 719     case '\005':  /* ^E */
 720          if (nextchar == '\0') {
 721 #if defined(MACOS_TRADITIONAL)
 722              {
 723                   char msg[256];
 724
 725                   sv_setnv(sv,(double)gMacPerl_OSErr);
 726                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 727              }
 728 #elif defined(VMS)
 729              {
 730 #                 include <descrip.h>
 731 #                 include <starlet.h>
 732                   char msg[255];
 733                   $DESCRIPTOR(msgdsc,msg);
 734                   sv_setnv(sv,(NV) vaxc$errno);
 735                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 736                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 737                   else
 738                        sv_setpvn(sv,"",0);
 739              }
 740 #elif defined(OS2)
 741              if (!(_emx_env & 0x200)) { /* Under DOS */
 742                   sv_setnv(sv, (NV)errno);
 743                   sv_setpv(sv, errno ? Strerror(errno) : "");
 744              } else {
 745                   if (errno != errno_isOS2) {
 746                        const int tmp = _syserrno();
 747                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 748                             Perl_rc = tmp;
 749                   }
 750                   sv_setnv(sv, (NV)Perl_rc);
 751                   sv_setpv(sv, os2error(Perl_rc));
 752              }
 753 #elif defined(WIN32)
 754              {
 755                   const DWORD dwErr = GetLastError();
 756                   sv_setnv(sv, (NV)dwErr);
 757                   if (dwErr) {
 758                        PerlProc_GetOSError(sv, dwErr);
 759                   }
 760                   else
 761                        sv_setpvn(sv, "", 0);
 762                   SetLastError(dwErr);
 763              }
 764 #else
 765              {
 766                  const int saveerrno = errno;
 767                  sv_setnv(sv, (NV)errno);
 768                  sv_setpv(sv, errno ? Strerror(errno) : "");
 769                  errno = saveerrno;
 770              }
 771 #endif
 772              SvRTRIM(sv);
 773              SvNOK_on(sv);      /* what a wonderful hack! */
 774          }
 775          else if (strEQ(remaining, "NCODING"))
 776               sv_setsv(sv, PL_encoding);
 777          break;
 778     case '\006':                /* ^F */
 779         sv_setiv(sv, (IV)PL_maxsysfd);
 780         break;
 781     case '\010':                /* ^H */
 782         sv_setiv(sv, (IV)PL_hints);
 783         break;
 784     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 785         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, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
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 #endif
1322 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1323     (void) rsignal(sig, PL_csighandlerp);
1324     if (PL_sig_ignoring[sig]) return;
1325 #endif
1326 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1327     if (PL_sig_defaulting[sig])
1328 #ifdef KILL_BY_SIGPRC
1329             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1330 #else
1331             exit(1);
1332 #endif
1333 #endif
1334 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1335 #endif
1336    if (
1337 #ifdef SIGILL
1338            sig == SIGILL ||
1339 #endif
1340 #ifdef SIGBUS
1341            sig == SIGBUS ||
1342 #endif
1343 #ifdef SIGSEGV
1344            sig == SIGSEGV ||
1345 #endif
1346            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1347         /* Call the perl level handler now--
1348          * with risk we may be in malloc() etc. */
1349         (*PL_sighandlerp)(sig);
1350    else
1351         S_raise_signal(aTHX_ sig);
1352 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1353 #endif
1354 }
1355
1356 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1357 void
1358 Perl_csighandler_init(void)
1359 {
1360     int sig;
1361     if (PL_sig_handlers_initted) return;
1362
1363     for (sig = 1; sig < SIG_SIZE; sig++) {
1364 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1365         dTHX;
1366         PL_sig_defaulting[sig] = 1;
1367         (void) rsignal(sig, PL_csighandlerp);
1368 #endif
1369 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1370         PL_sig_ignoring[sig] = 0;
1371 #endif
1372     }
1373     PL_sig_handlers_initted = 1;
1374 }
1375 #endif
1376
1377 void
1378 Perl_despatch_signals(pTHX)
1379 {
1380     dVAR;
1381     int sig;
1382     PL_sig_pending = 0;
1383     for (sig = 1; sig < SIG_SIZE; sig++) {
1384         if (PL_psig_pend[sig]) {
1385             PERL_BLOCKSIG_ADD(set, sig);
1386             PL_psig_pend[sig] = 0;
1387             PERL_BLOCKSIG_BLOCK(set);
1388             (*PL_sighandlerp)(sig);
1389             PERL_BLOCKSIG_UNBLOCK(set);
1390         }
1391     }
1392 }
1393
1394 int
1395 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1396 {
1397     dVAR;
1398     I32 i;
1399     SV** svp = NULL;
1400     /* Need to be careful with SvREFCNT_dec(), because that can have side
1401      * effects (due to closures). We must make sure that the new disposition
1402      * is in place before it is called.
1403      */
1404     SV* to_dec = NULL;
1405     STRLEN len;
1406 #ifdef HAS_SIGPROCMASK
1407     sigset_t set, save;
1408     SV* save_sv;
1409 #endif
1410
1411     register const char *s = MgPV_const(mg,len);
1412     if (*s == '_') {
1413         if (strEQ(s,"__DIE__"))
1414             svp = &PL_diehook;
1415         else if (strEQ(s,"__WARN__"))
1416             svp = &PL_warnhook;
1417         else
1418             Perl_croak(aTHX_ "No such hook: %s", s);
1419         i = 0;
1420         if (*svp) {
1421             if (*svp != PERL_WARNHOOK_FATAL)
1422                 to_dec = *svp;
1423             *svp = NULL;
1424         }
1425     }
1426     else {
1427         i = whichsig(s);        /* ...no, a brick */
1428         if (i <= 0) {
1429             if (ckWARN(WARN_SIGNAL))
1430                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1431             return 0;
1432         }
1433 #ifdef HAS_SIGPROCMASK
1434         /* Avoid having the signal arrive at a bad time, if possible. */
1435         sigemptyset(&set);
1436         sigaddset(&set,i);
1437         sigprocmask(SIG_BLOCK, &set, &save);
1438         ENTER;
1439         save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
1440         SAVEFREESV(save_sv);
1441         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1442 #endif
1443         PERL_ASYNC_CHECK();
1444 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1445         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1446 #endif
1447 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1448         PL_sig_ignoring[i] = 0;
1449 #endif
1450 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1451         PL_sig_defaulting[i] = 0;
1452 #endif
1453         SvREFCNT_dec(PL_psig_name[i]);
1454         to_dec = PL_psig_ptr[i];
1455         PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1456         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1457         PL_psig_name[i] = newSVpvn(s, len);
1458         SvREADONLY_on(PL_psig_name[i]);
1459     }
1460     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1461         if (i) {
1462             (void)rsignal(i, PL_csighandlerp);
1463 #ifdef HAS_SIGPROCMASK
1464             LEAVE;
1465 #endif
1466         }
1467         else
1468             *svp = SvREFCNT_inc_simple_NN(sv);
1469         if(to_dec)
1470             SvREFCNT_dec(to_dec);
1471         return 0;
1472     }
1473     s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1474     if (strEQ(s,"IGNORE")) {
1475         if (i) {
1476 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1477             PL_sig_ignoring[i] = 1;
1478             (void)rsignal(i, PL_csighandlerp);
1479 #else
1480             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1481 #endif
1482         }
1483     }
1484     else if (strEQ(s,"DEFAULT") || !*s) {
1485         if (i)
1486 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1487           {
1488             PL_sig_defaulting[i] = 1;
1489             (void)rsignal(i, PL_csighandlerp);
1490           }
1491 #else
1492             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1493 #endif
1494     }
1495     else {
1496         /*
1497          * We should warn if HINT_STRICT_REFS, but without
1498          * access to a known hint bit in a known OP, we can't
1499          * tell whether HINT_STRICT_REFS is in force or not.
1500          */
1501         if (!strchr(s,':') && !strchr(s,'\''))
1502             Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
1503         if (i)
1504             (void)rsignal(i, PL_csighandlerp);
1505         else
1506             *svp = SvREFCNT_inc_simple_NN(sv);
1507     }
1508 #ifdef HAS_SIGPROCMASK
1509     if(i)
1510         LEAVE;
1511 #endif
1512     if(to_dec)
1513         SvREFCNT_dec(to_dec);
1514     return 0;
1515 }
1516 #endif /* !PERL_MICRO */
1517
1518 int
1519 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1520 {
1521     dVAR;
1522     HV* stash;
1523     PERL_UNUSED_ARG(sv);
1524
1525     /* Bail out if destruction is going on */
1526     if(PL_dirty) return 0;
1527
1528     /* Skip _isaelem because _isa will handle it shortly */
1529     if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1530         return 0;
1531
1532     /* XXX Once it's possible, we need to
1533        detect that our @ISA is aliased in
1534        other stashes, and act on the stashes
1535        of all of the aliases */
1536
1537     /* The first case occurs via setisa,
1538        the second via setisa_elem, which
1539        calls this same magic */
1540     stash = GvSTASH(
1541         SvTYPE(mg->mg_obj) == SVt_PVGV
1542             ? (GV*)mg->mg_obj
1543             : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1544     );
1545
1546     mro_isa_changed_in(stash);
1547
1548     return 0;
1549 }
1550
1551 int
1552 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1553 {
1554     dVAR;
1555     PERL_UNUSED_ARG(sv);
1556     PERL_UNUSED_ARG(mg);
1557     PL_amagic_generation++;
1558
1559     return 0;
1560 }
1561
1562 int
1563 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1564 {
1565     HV * const hv = (HV*)LvTARG(sv);
1566     I32 i = 0;
1567     PERL_UNUSED_ARG(mg);
1568
1569     if (hv) {
1570          (void) hv_iterinit(hv);
1571          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1572              i = HvKEYS(hv);
1573          else {
1574              while (hv_iternext(hv))
1575                  i++;
1576          }
1577     }
1578
1579     sv_setiv(sv, (IV)i);
1580     return 0;
1581 }
1582
1583 int
1584 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1585 {
1586     PERL_UNUSED_ARG(mg);
1587     if (LvTARG(sv)) {
1588         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1589     }
1590     return 0;
1591 }
1592
1593 /* caller is responsible for stack switching/cleanup */
1594 STATIC int
1595 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1596 {
1597     dVAR;
1598     dSP;
1599
1600     PUSHMARK(SP);
1601     EXTEND(SP, n);
1602     PUSHs(SvTIED_obj(sv, mg));
1603     if (n > 1) {
1604         if (mg->mg_ptr) {
1605             if (mg->mg_len >= 0)
1606                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1607             else if (mg->mg_len == HEf_SVKEY)
1608                 PUSHs((SV*)mg->mg_ptr);
1609         }
1610         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1611             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1612         }
1613     }
1614     if (n > 2) {
1615         PUSHs(val);
1616     }
1617     PUTBACK;
1618
1619     return call_method(meth, flags);
1620 }
1621
1622 STATIC int
1623 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1624 {
1625     dVAR; dSP;
1626
1627     ENTER;
1628     SAVETMPS;
1629     PUSHSTACKi(PERLSI_MAGIC);
1630
1631     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1632         sv_setsv(sv, *PL_stack_sp--);
1633     }
1634
1635     POPSTACK;
1636     FREETMPS;
1637     LEAVE;
1638     return 0;
1639 }
1640
1641 int
1642 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1643 {
1644     if (mg->mg_ptr)
1645         mg->mg_flags |= MGf_GSKIP;
1646     magic_methpack(sv,mg,"FETCH");
1647     return 0;
1648 }
1649
1650 int
1651 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1652 {
1653     dVAR; dSP;
1654     ENTER;
1655     PUSHSTACKi(PERLSI_MAGIC);
1656     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1657     POPSTACK;
1658     LEAVE;
1659     return 0;
1660 }
1661
1662 int
1663 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1664 {
1665     return magic_methpack(sv,mg,"DELETE");
1666 }
1667
1668
1669 U32
1670 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1671 {
1672     dVAR; dSP;
1673     I32 retval = 0;
1674
1675     ENTER;
1676     SAVETMPS;
1677     PUSHSTACKi(PERLSI_MAGIC);
1678     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1679         sv = *PL_stack_sp--;
1680         retval = SvIV(sv)-1;
1681         if (retval < -1)
1682             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1683     }
1684     POPSTACK;
1685     FREETMPS;
1686     LEAVE;
1687     return (U32) retval;
1688 }
1689
1690 int
1691 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1692 {
1693     dVAR; dSP;
1694
1695     ENTER;
1696     PUSHSTACKi(PERLSI_MAGIC);
1697     PUSHMARK(SP);
1698     XPUSHs(SvTIED_obj(sv, mg));
1699     PUTBACK;
1700     call_method("CLEAR", G_SCALAR|G_DISCARD);
1701     POPSTACK;
1702     LEAVE;
1703
1704     return 0;
1705 }
1706
1707 int
1708 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1709 {
1710     dVAR; dSP;
1711     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1712
1713     ENTER;
1714     SAVETMPS;
1715     PUSHSTACKi(PERLSI_MAGIC);
1716     PUSHMARK(SP);
1717     EXTEND(SP, 2);
1718     PUSHs(SvTIED_obj(sv, mg));
1719     if (SvOK(key))
1720         PUSHs(key);
1721     PUTBACK;
1722
1723     if (call_method(meth, G_SCALAR))
1724         sv_setsv(key, *PL_stack_sp--);
1725
1726     POPSTACK;
1727     FREETMPS;
1728     LEAVE;
1729     return 0;
1730 }
1731
1732 int
1733 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1734 {
1735     return magic_methpack(sv,mg,"EXISTS");
1736 }
1737
1738 SV *
1739 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1740 {
1741     dVAR; dSP;
1742     SV *retval;
1743     SV * const tied = SvTIED_obj((SV*)hv, mg);
1744     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1745
1746     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1747         SV *key;
1748         if (HvEITER_get(hv))
1749             /* we are in an iteration so the hash cannot be empty */
1750             return &PL_sv_yes;
1751         /* no xhv_eiter so now use FIRSTKEY */
1752         key = sv_newmortal();
1753         magic_nextpack((SV*)hv, mg, key);
1754         HvEITER_set(hv, NULL);     /* need to reset iterator */
1755         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1756     }
1757
1758     /* there is a SCALAR method that we can call */
1759     ENTER;
1760     PUSHSTACKi(PERLSI_MAGIC);
1761     PUSHMARK(SP);
1762     EXTEND(SP, 1);
1763     PUSHs(tied);
1764     PUTBACK;
1765
1766     if (call_method("SCALAR", G_SCALAR))
1767         retval = *PL_stack_sp--;
1768     else
1769         retval = &PL_sv_undef;
1770     POPSTACK;
1771     LEAVE;
1772     return retval;
1773 }
1774
1775 int
1776 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1777 {
1778     dVAR;
1779     GV * const gv = PL_DBline;
1780     const I32 i = SvTRUE(sv);
1781     SV ** const svp = av_fetch(GvAV(gv),
1782                      atoi(MgPV_nolen_const(mg)), FALSE);
1783     if (svp && SvIOKp(*svp)) {
1784         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1785         if (o) {
1786             /* set or clear breakpoint in the relevant control op */
1787             if (i)
1788                 o->op_flags |= OPf_SPECIAL;
1789             else
1790                 o->op_flags &= ~OPf_SPECIAL;
1791         }
1792     }
1793     return 0;
1794 }
1795
1796 int
1797 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1798 {
1799     dVAR;
1800     const AV * const obj = (AV*)mg->mg_obj;
1801     if (obj) {
1802         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1803     } else {
1804         SvOK_off(sv);
1805     }
1806     return 0;
1807 }
1808
1809 int
1810 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1811 {
1812     dVAR;
1813     AV * const obj = (AV*)mg->mg_obj;
1814     if (obj) {
1815         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1816     } else {
1817         if (ckWARN(WARN_MISC))
1818             Perl_warner(aTHX_ packWARN(WARN_MISC),
1819                         "Attempt to set length of freed array");
1820     }
1821     return 0;
1822 }
1823
1824 int
1825 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1826 {
1827     dVAR;
1828     PERL_UNUSED_ARG(sv);
1829     /* during global destruction, mg_obj may already have been freed */
1830     if (PL_in_clean_all)
1831         return 0;
1832
1833     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1834
1835     if (mg) {
1836         /* arylen scalar holds a pointer back to the array, but doesn't own a
1837            reference. Hence the we (the array) are about to go away with it
1838            still pointing at us. Clear its pointer, else it would be pointing
1839            at free memory. See the comment in sv_magic about reference loops,
1840            and why it can't own a reference to us.  */
1841         mg->mg_obj = 0;
1842     }
1843     return 0;
1844 }
1845
1846 int
1847 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1848 {
1849     dVAR;
1850     SV* const lsv = LvTARG(sv);
1851     PERL_UNUSED_ARG(mg);
1852
1853     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1854         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1855         if (found && found->mg_len >= 0) {
1856             I32 i = found->mg_len;
1857             if (DO_UTF8(lsv))
1858                 sv_pos_b2u(lsv, &i);
1859             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1860             return 0;
1861         }
1862     }
1863     SvOK_off(sv);
1864     return 0;
1865 }
1866
1867 int
1868 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1869 {
1870     dVAR;
1871     SV* const lsv = LvTARG(sv);
1872     SSize_t pos;
1873     STRLEN len;
1874     STRLEN ulen = 0;
1875     MAGIC* found;
1876
1877     PERL_UNUSED_ARG(mg);
1878
1879     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1880         found = mg_find(lsv, PERL_MAGIC_regex_global);
1881     else
1882         found = NULL;
1883     if (!found) {
1884         if (!SvOK(sv))
1885             return 0;
1886 #ifdef PERL_OLD_COPY_ON_WRITE
1887     if (SvIsCOW(lsv))
1888         sv_force_normal_flags(lsv, 0);
1889 #endif
1890         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
1891                             NULL, 0);
1892     }
1893     else if (!SvOK(sv)) {
1894         found->mg_len = -1;
1895         return 0;
1896     }
1897     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1898
1899     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
1900
1901     if (DO_UTF8(lsv)) {
1902         ulen = sv_len_utf8(lsv);
1903         if (ulen)
1904             len = ulen;
1905     }
1906
1907     if (pos < 0) {
1908         pos += len;
1909         if (pos < 0)
1910             pos = 0;
1911     }
1912     else if (pos > (SSize_t)len)
1913         pos = len;
1914
1915     if (ulen) {
1916         I32 p = pos;
1917         sv_pos_u2b(lsv, &p, 0);
1918         pos = p;
1919     }
1920
1921     found->mg_len = pos;
1922     found->mg_flags &= ~MGf_MINMATCH;
1923
1924     return 0;
1925 }
1926
1927 int
1928 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1929 {
1930     GV* gv;
1931     PERL_UNUSED_ARG(mg);
1932
1933     Perl_croak(aTHX_ "Perl_magic_setglob is dead code?");
1934
1935     if (!SvOK(sv))
1936         return 0;
1937     if (isGV_with_GP(sv)) {
1938         /* We're actually already a typeglob, so don't need the stuff below.
1939          */
1940         return 0;
1941     }
1942     gv =  gv_fetchsv(sv, GV_ADD, SVt_PVGV);
1943     if (sv == (SV*)gv)
1944         return 0;
1945     if (GvGP(sv))
1946         gp_free((GV*)sv);
1947     GvGP(sv) = gp_ref(GvGP(gv));
1948     return 0;
1949 }
1950
1951 int
1952 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1953 {
1954     STRLEN len;
1955     SV * const lsv = LvTARG(sv);
1956     const char * const tmps = SvPV_const(lsv,len);
1957     I32 offs = LvTARGOFF(sv);
1958     I32 rem = LvTARGLEN(sv);
1959     PERL_UNUSED_ARG(mg);
1960
1961     if (SvUTF8(lsv))
1962         sv_pos_u2b(lsv, &offs, &rem);
1963     if (offs > (I32)len)
1964         offs = len;
1965     if (rem + offs > (I32)len)
1966         rem = len - offs;
1967     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1968     if (SvUTF8(lsv))
1969         SvUTF8_on(sv);
1970     return 0;
1971 }
1972
1973 int
1974 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1975 {
1976     dVAR;
1977     STRLEN len;
1978     const char * const tmps = SvPV_const(sv, len);
1979     SV * const lsv = LvTARG(sv);
1980     I32 lvoff = LvTARGOFF(sv);
1981     I32 lvlen = LvTARGLEN(sv);
1982     PERL_UNUSED_ARG(mg);
1983
1984     if (DO_UTF8(sv)) {
1985         sv_utf8_upgrade(lsv);
1986         sv_pos_u2b(lsv, &lvoff, &lvlen);
1987         sv_insert(lsv, lvoff, lvlen, tmps, len);
1988         LvTARGLEN(sv) = sv_len_utf8(sv);
1989         SvUTF8_on(lsv);
1990     }
1991     else if (lsv && SvUTF8(lsv)) {
1992         const char *utf8;
1993         sv_pos_u2b(lsv, &lvoff, &lvlen);
1994         LvTARGLEN(sv) = len;
1995         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
1996         sv_insert(lsv, lvoff, lvlen, utf8, len);
1997         Safefree(utf8);
1998     }
1999     else {
2000         sv_insert(lsv, lvoff, lvlen, tmps, len);
2001         LvTARGLEN(sv) = len;
2002     }
2003
2004
2005     return 0;
2006 }
2007
2008 int
2009 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2010 {
2011     dVAR;
2012     PERL_UNUSED_ARG(sv);
2013     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2014     return 0;
2015 }
2016
2017 int
2018 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2019 {
2020     dVAR;
2021     PERL_UNUSED_ARG(sv);
2022     /* update taint status */
2023     if (PL_tainted)
2024         mg->mg_len |= 1;
2025     else
2026         mg->mg_len &= ~1;
2027     return 0;
2028 }
2029
2030 int
2031 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2032 {
2033     SV * const lsv = LvTARG(sv);
2034     PERL_UNUSED_ARG(mg);
2035
2036     if (lsv)
2037         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2038     else
2039         SvOK_off(sv);
2040
2041     return 0;
2042 }
2043
2044 int
2045 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2046 {
2047     PERL_UNUSED_ARG(mg);
2048     do_vecset(sv);      /* XXX slurp this routine */
2049     return 0;
2050 }
2051
2052 int
2053 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2054 {
2055     dVAR;
2056     SV *targ = NULL;
2057     if (LvTARGLEN(sv)) {
2058         if (mg->mg_obj) {
2059             SV * const ahv = LvTARG(sv);
2060             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2061             if (he)
2062                 targ = HeVAL(he);
2063         }
2064         else {
2065             AV* const av = (AV*)LvTARG(sv);
2066             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2067                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2068         }
2069         if (targ && (targ != &PL_sv_undef)) {
2070             /* somebody else defined it for us */
2071             SvREFCNT_dec(LvTARG(sv));
2072             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2073             LvTARGLEN(sv) = 0;
2074             SvREFCNT_dec(mg->mg_obj);
2075             mg->mg_obj = NULL;
2076             mg->mg_flags &= ~MGf_REFCOUNTED;
2077         }
2078     }
2079     else
2080         targ = LvTARG(sv);
2081     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2082     return 0;
2083 }
2084
2085 int
2086 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2087 {
2088     PERL_UNUSED_ARG(mg);
2089     if (LvTARGLEN(sv))
2090         vivify_defelem(sv);
2091     if (LvTARG(sv)) {
2092         sv_setsv(LvTARG(sv), sv);
2093         SvSETMAGIC(LvTARG(sv));
2094     }
2095     return 0;
2096 }
2097
2098 void
2099 Perl_vivify_defelem(pTHX_ SV *sv)
2100 {
2101     dVAR;
2102     MAGIC *mg;
2103     SV *value = NULL;
2104
2105     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2106         return;
2107     if (mg->mg_obj) {
2108         SV * const ahv = LvTARG(sv);
2109         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2110         if (he)
2111             value = HeVAL(he);
2112         if (!value || value == &PL_sv_undef)
2113             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2114     }
2115     else {
2116         AV* const av = (AV*)LvTARG(sv);
2117         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2118             LvTARG(sv) = NULL;  /* array can't be extended */
2119         else {
2120             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2121             if (!svp || (value = *svp) == &PL_sv_undef)
2122                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2123         }
2124     }
2125     SvREFCNT_inc_simple_void(value);
2126     SvREFCNT_dec(LvTARG(sv));
2127     LvTARG(sv) = value;
2128     LvTARGLEN(sv) = 0;
2129     SvREFCNT_dec(mg->mg_obj);
2130     mg->mg_obj = NULL;
2131     mg->mg_flags &= ~MGf_REFCOUNTED;
2132 }
2133
2134 int
2135 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2136 {
2137     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2138 }
2139
2140 int
2141 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2142 {
2143     PERL_UNUSED_CONTEXT;
2144     mg->mg_len = -1;
2145     SvSCREAM_off(sv);
2146     return 0;
2147 }
2148
2149 int
2150 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
2151 {
2152     PERL_UNUSED_ARG(mg);
2153     sv_unmagic(sv, PERL_MAGIC_bm);
2154     SvTAIL_off(sv);
2155     SvVALID_off(sv);
2156     return 0;
2157 }
2158
2159 int
2160 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
2161 {
2162     PERL_UNUSED_ARG(mg);
2163     sv_unmagic(sv, PERL_MAGIC_fm);
2164     SvCOMPILED_off(sv);
2165     return 0;
2166 }
2167
2168 int
2169 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2170 {
2171     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2172
2173     if (uf && uf->uf_set)
2174         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2175     return 0;
2176 }
2177
2178 int
2179 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2180 {
2181     PERL_UNUSED_ARG(mg);
2182     sv_unmagic(sv, PERL_MAGIC_qr);
2183     return 0;
2184 }
2185
2186 int
2187 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2188 {
2189     dVAR;
2190     regexp * const re = (regexp *)mg->mg_obj;
2191     PERL_UNUSED_ARG(sv);
2192
2193     ReREFCNT_dec(re);
2194     return 0;
2195 }
2196
2197 #ifdef USE_LOCALE_COLLATE
2198 int
2199 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2200 {
2201     /*
2202      * RenE<eacute> Descartes said "I think not."
2203      * and vanished with a faint plop.
2204      */
2205     PERL_UNUSED_CONTEXT;
2206     PERL_UNUSED_ARG(sv);
2207     if (mg->mg_ptr) {
2208         Safefree(mg->mg_ptr);
2209         mg->mg_ptr = NULL;
2210         mg->mg_len = -1;
2211     }
2212     return 0;
2213 }
2214 #endif /* USE_LOCALE_COLLATE */
2215
2216 /* Just clear the UTF-8 cache data. */
2217 int
2218 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2219 {
2220     PERL_UNUSED_CONTEXT;
2221     PERL_UNUSED_ARG(sv);
2222     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2223     mg->mg_ptr = NULL;
2224     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2225     return 0;
2226 }
2227
2228 int
2229 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2230 {
2231     dVAR;
2232     register const char *s;
2233     register I32 paren;
2234     register const REGEXP * rx;
2235     const char * const remaining = mg->mg_ptr + 1;
2236     I32 i;
2237     STRLEN len;
2238
2239     switch (*mg->mg_ptr) {
2240     case '\015': /* $^MATCH */
2241       if (strEQ(remaining, "ATCH"))
2242           goto do_match;
2243     case '`': /* ${^PREMATCH} caught below */
2244       do_prematch:
2245       paren = RX_BUFF_IDX_PREMATCH;
2246       goto setparen;
2247     case '\'': /* ${^POSTMATCH} caught below */
2248       do_postmatch:
2249       paren = RX_BUFF_IDX_POSTMATCH;
2250       goto setparen;
2251     case '&':
2252       do_match:
2253       paren = RX_BUFF_IDX_FULLMATCH;
2254       goto setparen;
2255     case '1': case '2': case '3': case '4':
2256     case '5': case '6': case '7': case '8': case '9':
2257       paren = atoi(mg->mg_ptr);
2258       setparen:
2259         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2260             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2261             break;
2262         } else {
2263             /* Croak with a READONLY error when a numbered match var is
2264              * set without a previous pattern match. Unless it's C<local $1>
2265              */
2266             if (!PL_localizing) {
2267                 Perl_croak(aTHX_ PL_no_modify);
2268             }
2269         }
2270     case '\001':        /* ^A */
2271         sv_setsv(PL_bodytarget, sv);
2272         break;
2273     case '\003':        /* ^C */
2274         PL_minus_c = (bool)SvIV(sv);
2275         break;
2276
2277     case '\004':        /* ^D */
2278 #ifdef DEBUGGING
2279         s = SvPV_nolen_const(sv);
2280         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2281         DEBUG_x(dump_all());
2282 #else
2283         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2284 #endif
2285         break;
2286     case '\005':  /* ^E */
2287         if (*(mg->mg_ptr+1) == '\0') {
2288 #ifdef MACOS_TRADITIONAL
2289             gMacPerl_OSErr = SvIV(sv);
2290 #else
2291 #  ifdef VMS
2292             set_vaxc_errno(SvIV(sv));
2293 #  else
2294 #    ifdef WIN32
2295             SetLastError( SvIV(sv) );
2296 #    else
2297 #      ifdef OS2
2298             os2_setsyserrno(SvIV(sv));
2299 #      else
2300             /* will anyone ever use this? */
2301             SETERRNO(SvIV(sv), 4);
2302 #      endif
2303 #    endif
2304 #  endif
2305 #endif
2306         }
2307         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2308             if (PL_encoding)
2309                 SvREFCNT_dec(PL_encoding);
2310             if (SvOK(sv) || SvGMAGICAL(sv)) {
2311                 PL_encoding = newSVsv(sv);
2312             }
2313             else {
2314                 PL_encoding = NULL;
2315             }
2316         }
2317         break;
2318     case '\006':        /* ^F */
2319         PL_maxsysfd = SvIV(sv);
2320         break;
2321     case '\010':        /* ^H */
2322         PL_hints = SvIV(sv);
2323         break;
2324     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2325         Safefree(PL_inplace);
2326         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2327         break;
2328     case '\017':        /* ^O */
2329         if (*(mg->mg_ptr+1) == '\0') {
2330             Safefree(PL_osname);
2331             PL_osname = NULL;
2332             if (SvOK(sv)) {
2333                 TAINT_PROPER("assigning to $^O");
2334                 PL_osname = savesvpv(sv);
2335             }
2336         }
2337         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2338             STRLEN len;
2339             const char *const start = SvPV(sv, len);
2340             const char *out = (const char*)memchr(start, '\0', len);
2341             SV *tmp;
2342             struct refcounted_he *tmp_he;
2343
2344
2345             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2346             PL_hints
2347                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2348
2349             /* Opening for input is more common than opening for output, so
2350                ensure that hints for input are sooner on linked list.  */
2351             tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2352                              : newSVpvs(""));
2353             SvFLAGS(tmp) |= SvUTF8(sv);
2354
2355             tmp_he
2356                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2357                                          sv_2mortal(newSVpvs("open>")), tmp);
2358
2359             /* The UTF-8 setting is carried over  */
2360             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2361
2362             PL_compiling.cop_hints_hash
2363                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2364                                          sv_2mortal(newSVpvs("open<")), tmp);
2365         }
2366         break;
2367     case '\020':        /* ^P */
2368       if (*remaining == '\0') { /* ^P */
2369           PL_perldb = SvIV(sv);
2370           if (PL_perldb && !PL_DBsingle)
2371               init_debugger();
2372           break;
2373       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2374           goto do_prematch;
2375       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2376           goto do_postmatch;
2377       }
2378     case '\024':        /* ^T */
2379 #ifdef BIG_TIME
2380         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2381 #else
2382         PL_basetime = (Time_t)SvIV(sv);
2383 #endif
2384         break;
2385     case '\025':        /* ^UTF8CACHE */
2386          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2387              PL_utf8cache = (signed char) sv_2iv(sv);
2388          }
2389          break;
2390     case '\027':        /* ^W & $^WARNING_BITS */
2391         if (*(mg->mg_ptr+1) == '\0') {
2392             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2393                 i = SvIV(sv);
2394                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2395                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2396             }
2397         }
2398         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2399             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2400                 if (!SvPOK(sv) && PL_localizing) {
2401                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2402                     PL_compiling.cop_warnings = pWARN_NONE;
2403                     break;
2404                 }
2405                 {
2406                     STRLEN len, i;
2407                     int accumulate = 0 ;
2408                     int any_fatals = 0 ;
2409                     const char * const ptr = SvPV_const(sv, len) ;
2410                     for (i = 0 ; i < len ; ++i) {
2411                         accumulate |= ptr[i] ;
2412                         any_fatals |= (ptr[i] & 0xAA) ;
2413                     }
2414                     if (!accumulate) {
2415                         if (!specialWARN(PL_compiling.cop_warnings))
2416                             PerlMemShared_free(PL_compiling.cop_warnings);
2417                         PL_compiling.cop_warnings = pWARN_NONE;
2418                     }
2419                     /* Yuck. I can't see how to abstract this:  */
2420                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2421                                        WARN_ALL) && !any_fatals) {
2422                         if (!specialWARN(PL_compiling.cop_warnings))
2423                             PerlMemShared_free(PL_compiling.cop_warnings);
2424                         PL_compiling.cop_warnings = pWARN_ALL;
2425                         PL_dowarn |= G_WARN_ONCE ;
2426                     }
2427                     else {
2428                         STRLEN len;
2429                         const char *const p = SvPV_const(sv, len);
2430
2431                         PL_compiling.cop_warnings
2432                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2433                                                          p, len);
2434
2435                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2436                             PL_dowarn |= G_WARN_ONCE ;
2437                     }
2438
2439                 }
2440             }
2441         }
2442         break;
2443     case '.':
2444         if (PL_localizing) {
2445             if (PL_localizing == 1)
2446                 SAVESPTR(PL_last_in_gv);
2447         }
2448         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2449             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2450         break;
2451     case '^':
2452         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2453         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2454         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2455         break;
2456     case '~':
2457         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2458         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2459         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2460         break;
2461     case '=':
2462         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2463         break;
2464     case '-':
2465         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2466         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2467             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2468         break;
2469     case '%':
2470         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2471         break;
2472     case '|':
2473         {
2474             IO * const io = GvIOp(PL_defoutgv);
2475             if(!io)
2476               break;
2477             if ((SvIV(sv)) == 0)
2478                 IoFLAGS(io) &= ~IOf_FLUSH;
2479             else {
2480                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2481                     PerlIO *ofp = IoOFP(io);
2482                     if (ofp)
2483                         (void)PerlIO_flush(ofp);
2484                     IoFLAGS(io) |= IOf_FLUSH;
2485                 }
2486             }
2487         }
2488         break;
2489     case '/':
2490         SvREFCNT_dec(PL_rs);
2491         PL_rs = newSVsv(sv);
2492         break;
2493     case '\\':
2494         if (PL_ors_sv)
2495             SvREFCNT_dec(PL_ors_sv);
2496         if (SvOK(sv) || SvGMAGICAL(sv)) {
2497             PL_ors_sv = newSVsv(sv);
2498         }
2499         else {
2500             PL_ors_sv = NULL;
2501         }
2502         break;
2503     case ',':
2504         if (PL_ofs_sv)
2505             SvREFCNT_dec(PL_ofs_sv);
2506         if (SvOK(sv) || SvGMAGICAL(sv)) {
2507             PL_ofs_sv = newSVsv(sv);
2508         }
2509         else {
2510             PL_ofs_sv = NULL;
2511         }
2512         break;
2513     case '[':
2514         CopARYBASE_set(&PL_compiling, SvIV(sv));
2515         break;
2516     case '?':
2517 #ifdef COMPLEX_STATUS
2518         if (PL_localizing == 2) {
2519             PL_statusvalue = LvTARGOFF(sv);
2520             PL_statusvalue_vms = LvTARGLEN(sv);
2521         }
2522         else
2523 #endif
2524 #ifdef VMSISH_STATUS
2525         if (VMSISH_STATUS)
2526             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2527         else
2528 #endif
2529             STATUS_UNIX_EXIT_SET(SvIV(sv));
2530         break;
2531     case '!':
2532         {
2533 #ifdef VMS
2534 #   define PERL_VMS_BANG vaxc$errno
2535 #else
2536 #   define PERL_VMS_BANG 0
2537 #endif
2538         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2539                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2540         }
2541         break;
2542     case '<':
2543         PL_uid = SvIV(sv);
2544         if (PL_delaymagic) {
2545             PL_delaymagic |= DM_RUID;
2546             break;                              /* don't do magic till later */
2547         }
2548 #ifdef HAS_SETRUID
2549         (void)setruid((Uid_t)PL_uid);
2550 #else
2551 #ifdef HAS_SETREUID
2552         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2553 #else
2554 #ifdef HAS_SETRESUID
2555       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2556 #else
2557         if (PL_uid == PL_euid) {                /* special case $< = $> */
2558 #ifdef PERL_DARWIN
2559             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2560             if (PL_uid != 0 && PerlProc_getuid() == 0)
2561                 (void)PerlProc_setuid(0);
2562 #endif
2563             (void)PerlProc_setuid(PL_uid);
2564         } else {
2565             PL_uid = PerlProc_getuid();
2566             Perl_croak(aTHX_ "setruid() not implemented");
2567         }
2568 #endif
2569 #endif
2570 #endif
2571         PL_uid = PerlProc_getuid();
2572         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2573         break;
2574     case '>':
2575         PL_euid = SvIV(sv);
2576         if (PL_delaymagic) {
2577             PL_delaymagic |= DM_EUID;
2578             break;                              /* don't do magic till later */
2579         }
2580 #ifdef HAS_SETEUID
2581         (void)seteuid((Uid_t)PL_euid);
2582 #else
2583 #ifdef HAS_SETREUID
2584         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2585 #else
2586 #ifdef HAS_SETRESUID
2587         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2588 #else
2589         if (PL_euid == PL_uid)          /* special case $> = $< */
2590             PerlProc_setuid(PL_euid);
2591         else {
2592             PL_euid = PerlProc_geteuid();
2593             Perl_croak(aTHX_ "seteuid() not implemented");
2594         }
2595 #endif
2596 #endif
2597 #endif
2598         PL_euid = PerlProc_geteuid();
2599         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2600         break;
2601     case '(':
2602         PL_gid = SvIV(sv);
2603         if (PL_delaymagic) {
2604             PL_delaymagic |= DM_RGID;
2605             break;                              /* don't do magic till later */
2606         }
2607 #ifdef HAS_SETRGID
2608         (void)setrgid((Gid_t)PL_gid);
2609 #else
2610 #ifdef HAS_SETREGID
2611         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2612 #else
2613 #ifdef HAS_SETRESGID
2614       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2615 #else
2616         if (PL_gid == PL_egid)                  /* special case $( = $) */
2617             (void)PerlProc_setgid(PL_gid);
2618         else {
2619             PL_gid = PerlProc_getgid();
2620             Perl_croak(aTHX_ "setrgid() not implemented");
2621         }
2622 #endif
2623 #endif
2624 #endif
2625         PL_gid = PerlProc_getgid();
2626         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2627         break;
2628     case ')':
2629 #ifdef HAS_SETGROUPS
2630         {
2631             const char *p = SvPV_const(sv, len);
2632             Groups_t *gary = NULL;
2633
2634             while (isSPACE(*p))
2635                 ++p;
2636             PL_egid = Atol(p);
2637             for (i = 0; i < NGROUPS; ++i) {
2638                 while (*p && !isSPACE(*p))
2639                     ++p;
2640                 while (isSPACE(*p))
2641                     ++p;
2642                 if (!*p)
2643                     break;
2644                 if(!gary)
2645                     Newx(gary, i + 1, Groups_t);
2646                 else
2647                     Renew(gary, i + 1, Groups_t);
2648                 gary[i] = Atol(p);
2649             }
2650             if (i)
2651                 (void)setgroups(i, gary);
2652             Safefree(gary);
2653         }
2654 #else  /* HAS_SETGROUPS */
2655         PL_egid = SvIV(sv);
2656 #endif /* HAS_SETGROUPS */
2657         if (PL_delaymagic) {
2658             PL_delaymagic |= DM_EGID;
2659             break;                              /* don't do magic till later */
2660         }
2661 #ifdef HAS_SETEGID
2662         (void)setegid((Gid_t)PL_egid);
2663 #else
2664 #ifdef HAS_SETREGID
2665         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2666 #else
2667 #ifdef HAS_SETRESGID
2668         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2669 #else
2670         if (PL_egid == PL_gid)                  /* special case $) = $( */
2671             (void)PerlProc_setgid(PL_egid);
2672         else {
2673             PL_egid = PerlProc_getegid();
2674             Perl_croak(aTHX_ "setegid() not implemented");
2675         }
2676 #endif
2677 #endif
2678 #endif
2679         PL_egid = PerlProc_getegid();
2680         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2681         break;
2682     case ':':
2683         PL_chopset = SvPV_force(sv,len);
2684         break;
2685 #ifndef MACOS_TRADITIONAL
2686     case '0':
2687         LOCK_DOLLARZERO_MUTEX;
2688 #ifdef HAS_SETPROCTITLE
2689         /* The BSDs don't show the argv[] in ps(1) output, they
2690          * show a string from the process struct and provide
2691          * the setproctitle() routine to manipulate that. */
2692         if (PL_origalen != 1) {
2693             s = SvPV_const(sv, len);
2694 #   if __FreeBSD_version > 410001
2695             /* The leading "-" removes the "perl: " prefix,
2696              * but not the "(perl) suffix from the ps(1)
2697              * output, because that's what ps(1) shows if the
2698              * argv[] is modified. */
2699             setproctitle("-%s", s);
2700 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2701             /* This doesn't really work if you assume that
2702              * $0 = 'foobar'; will wipe out 'perl' from the $0
2703              * because in ps(1) output the result will be like
2704              * sprintf("perl: %s (perl)", s)
2705              * I guess this is a security feature:
2706              * one (a user process) cannot get rid of the original name.
2707              * --jhi */
2708             setproctitle("%s", s);
2709 #   endif
2710         }
2711 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2712         if (PL_origalen != 1) {
2713              union pstun un;
2714              s = SvPV_const(sv, len);
2715              un.pst_command = (char *)s;
2716              pstat(PSTAT_SETCMD, un, len, 0, 0);
2717         }
2718 #else
2719         if (PL_origalen > 1) {
2720             /* PL_origalen is set in perl_parse(). */
2721             s = SvPV_force(sv,len);
2722             if (len >= (STRLEN)PL_origalen-1) {
2723                 /* Longer than original, will be truncated. We assume that
2724                  * PL_origalen bytes are available. */
2725                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2726             }
2727             else {
2728                 /* Shorter than original, will be padded. */
2729 #ifdef PERL_DARWIN
2730                 /* Special case for Mac OS X: see [perl #38868] */
2731                 const int pad = 0;
2732 #else
2733                 /* Is the space counterintuitive?  Yes.
2734                  * (You were expecting \0?)
2735                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2736                  * --jhi */
2737                 const int pad = ' ';
2738 #endif
2739                 Copy(s, PL_origargv[0], len, char);
2740                 PL_origargv[0][len] = 0;
2741                 memset(PL_origargv[0] + len + 1,
2742                        pad,  PL_origalen - len - 1);
2743             }
2744             PL_origargv[0][PL_origalen-1] = 0;
2745             for (i = 1; i < PL_origargc; i++)
2746                 PL_origargv[i] = 0;
2747         }
2748 #endif
2749         UNLOCK_DOLLARZERO_MUTEX;
2750         break;
2751 #endif
2752     }
2753     return 0;
2754 }
2755
2756 I32
2757 Perl_whichsig(pTHX_ const char *sig)
2758 {
2759     register char* const* sigv;
2760     PERL_UNUSED_CONTEXT;
2761
2762     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2763         if (strEQ(sig,*sigv))
2764             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2765 #ifdef SIGCLD
2766     if (strEQ(sig,"CHLD"))
2767         return SIGCLD;
2768 #endif
2769 #ifdef SIGCHLD
2770     if (strEQ(sig,"CLD"))
2771         return SIGCHLD;
2772 #endif
2773     return -1;
2774 }
2775
2776 Signal_t
2777 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2778 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2779 #else
2780 Perl_sighandler(int sig)
2781 #endif
2782 {
2783 #ifdef PERL_GET_SIG_CONTEXT
2784     dTHXa(PERL_GET_SIG_CONTEXT);
2785 #else
2786     dTHX;
2787 #endif
2788     dSP;
2789     GV *gv = NULL;
2790     SV *sv = NULL;
2791     SV * const tSv = PL_Sv;
2792     CV *cv = NULL;
2793     OP *myop = PL_op;
2794     U32 flags = 0;
2795     XPV * const tXpv = PL_Xpv;
2796
2797     if (PL_savestack_ix + 15 <= PL_savestack_max)
2798         flags |= 1;
2799     if (PL_markstack_ptr < PL_markstack_max - 2)
2800         flags |= 4;
2801     if (PL_scopestack_ix < PL_scopestack_max - 3)
2802         flags |= 16;
2803
2804     if (!PL_psig_ptr[sig]) {
2805                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2806                                  PL_sig_name[sig]);
2807                 exit(sig);
2808         }
2809
2810     /* Max number of items pushed there is 3*n or 4. We cannot fix
2811        infinity, so we fix 4 (in fact 5): */
2812     if (flags & 1) {
2813         PL_savestack_ix += 5;           /* Protect save in progress. */
2814         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2815     }
2816     if (flags & 4)
2817         PL_markstack_ptr++;             /* Protect mark. */
2818     if (flags & 16)
2819         PL_scopestack_ix += 1;
2820     /* sv_2cv is too complicated, try a simpler variant first: */
2821     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2822         || SvTYPE(cv) != SVt_PVCV) {
2823         HV *st;
2824         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2825     }
2826
2827     if (!cv || !CvROOT(cv)) {
2828         if (ckWARN(WARN_SIGNAL))
2829             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2830                 PL_sig_name[sig], (gv ? GvENAME(gv)
2831                                 : ((cv && CvGV(cv))
2832                                    ? GvENAME(CvGV(cv))
2833                                    : "__ANON__")));
2834         goto cleanup;
2835     }
2836
2837     if(PL_psig_name[sig]) {
2838         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2839         flags |= 64;
2840 #if !defined(PERL_IMPLICIT_CONTEXT)
2841         PL_sig_sv = sv;
2842 #endif
2843     } else {
2844         sv = sv_newmortal();
2845         sv_setpv(sv,PL_sig_name[sig]);
2846     }
2847
2848     PUSHSTACKi(PERLSI_SIGNAL);
2849     PUSHMARK(SP);
2850     PUSHs(sv);
2851 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2852     {
2853          struct sigaction oact;
2854
2855          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2856               if (sip) {
2857                    HV *sih = newHV();
2858                    SV *rv  = newRV_noinc((SV*)sih);
2859                    /* The siginfo fields signo, code, errno, pid, uid,
2860                     * addr, status, and band are defined by POSIX/SUSv3. */
2861                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2862                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
2863 #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. */
2864                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
2865                    hv_stores(sih, "status",     newSViv(sip->si_status));
2866                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
2867                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
2868                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
2869                    hv_stores(sih, "band",       newSViv(sip->si_band));
2870 #endif
2871                    EXTEND(SP, 2);
2872                    PUSHs((SV*)rv);
2873                    PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2874               }
2875
2876          }
2877     }
2878 #endif
2879     PUTBACK;
2880
2881     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2882
2883     POPSTACK;
2884     if (SvTRUE(ERRSV)) {
2885 #ifndef PERL_MICRO
2886 #ifdef HAS_SIGPROCMASK
2887         /* Handler "died", for example to get out of a restart-able read().
2888          * Before we re-do that on its behalf re-enable the signal which was
2889          * blocked by the system when we entered.
2890          */
2891         sigset_t set;
2892         sigemptyset(&set);
2893         sigaddset(&set,sig);
2894         sigprocmask(SIG_UNBLOCK, &set, NULL);
2895 #else
2896         /* Not clear if this will work */
2897         (void)rsignal(sig, SIG_IGN);
2898         (void)rsignal(sig, PL_csighandlerp);
2899 #endif
2900 #endif /* !PERL_MICRO */
2901         Perl_die(aTHX_ NULL);
2902     }
2903 cleanup:
2904     if (flags & 1)
2905         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2906     if (flags & 4)
2907         PL_markstack_ptr--;
2908     if (flags & 16)
2909         PL_scopestack_ix -= 1;
2910     if (flags & 64)
2911         SvREFCNT_dec(sv);
2912     PL_op = myop;                       /* Apparently not needed... */
2913
2914     PL_Sv = tSv;                        /* Restore global temporaries. */
2915     PL_Xpv = tXpv;
2916     return;
2917 }
2918
2919
2920 static void
2921 S_restore_magic(pTHX_ const void *p)
2922 {
2923     dVAR;
2924     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2925     SV* const sv = mgs->mgs_sv;
2926
2927     if (!sv)
2928         return;
2929
2930     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2931     {
2932 #ifdef PERL_OLD_COPY_ON_WRITE
2933         /* While magic was saved (and off) sv_setsv may well have seen
2934            this SV as a prime candidate for COW.  */
2935         if (SvIsCOW(sv))
2936             sv_force_normal_flags(sv, 0);
2937 #endif
2938
2939         if (mgs->mgs_flags)
2940             SvFLAGS(sv) |= mgs->mgs_flags;
2941         else
2942             mg_magical(sv);
2943         if (SvGMAGICAL(sv)) {
2944             /* downgrade public flags to private,
2945                and discard any other private flags */
2946
2947             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2948             if (pubflags) {
2949                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2950                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2951             }
2952         }
2953     }
2954
2955     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2956
2957     /* If we're still on top of the stack, pop us off.  (That condition
2958      * will be satisfied if restore_magic was called explicitly, but *not*
2959      * if it's being called via leave_scope.)
2960      * The reason for doing this is that otherwise, things like sv_2cv()
2961      * may leave alloc gunk on the savestack, and some code
2962      * (e.g. sighandler) doesn't expect that...
2963      */
2964     if (PL_savestack_ix == mgs->mgs_ss_ix)
2965     {
2966         I32 popval = SSPOPINT;
2967         assert(popval == SAVEt_DESTRUCTOR_X);
2968         PL_savestack_ix -= 2;
2969         popval = SSPOPINT;
2970         assert(popval == SAVEt_ALLOC);
2971         popval = SSPOPINT;
2972         PL_savestack_ix -= popval;
2973     }
2974
2975 }
2976
2977 static void
2978 S_unwind_handler_stack(pTHX_ const void *p)
2979 {
2980     dVAR;
2981     const U32 flags = *(const U32*)p;
2982
2983     if (flags & 1)
2984         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2985 #if !defined(PERL_IMPLICIT_CONTEXT)
2986     if (flags & 64)
2987         SvREFCNT_dec(PL_sig_sv);
2988 #endif
2989 }
2990
2991 /*
2992 =for apidoc magic_sethint
2993
2994 Triggered by a store to %^H, records the key/value pair to
2995 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
2996 anything that would need a deep copy.  Maybe we should warn if we find a
2997 reference.
2998
2999 =cut
3000 */
3001 int
3002 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3003 {
3004     dVAR;
3005     assert(mg->mg_len == HEf_SVKEY);
3006
3007     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3008        an alternative leaf in there, with PL_compiling.cop_hints being used if
3009        it's NULL. If needed for threads, the alternative could lock a mutex,
3010        or take other more complex action.  */
3011
3012     /* Something changed in %^H, so it will need to be restored on scope exit.
3013        Doing this here saves a lot of doing it manually in perl code (and
3014        forgetting to do it, and consequent subtle errors.  */
3015     PL_hints |= HINT_LOCALIZE_HH;
3016     PL_compiling.cop_hints_hash
3017         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3018                                  (SV *)mg->mg_ptr, sv);
3019     return 0;
3020 }
3021
3022 /*
3023 =for apidoc magic_sethint
3024
3025 Triggered by a delete from %^H, records the key to
3026 C<PL_compiling.cop_hints_hash>.
3027
3028 =cut
3029 */
3030 int
3031 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3032 {
3033     dVAR;
3034     PERL_UNUSED_ARG(sv);
3035
3036     assert(mg->mg_len == HEf_SVKEY);
3037
3038     PERL_UNUSED_ARG(sv);
3039
3040     PL_hints |= HINT_LOCALIZE_HH;
3041     PL_compiling.cop_hints_hash
3042         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3043                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
3044     return 0;
3045 }
3046
3047 /*
3048  * Local variables:
3049  * c-indentation-style: bsd
3050  * c-basic-offset: 4
3051  * indent-tabs-mode: t
3052  * End:
3053  *
3054  * ex: set ts=8 sts=4 sw=4 noet:
3055  */