mg.c

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