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