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_setuvar(pTHX_ SV *sv, MAGIC *mg)
2131 {
2132     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2133
2134     if (uf && uf->uf_set)
2135         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2136     return 0;
2137 }
2138
2139 int
2140 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2141 {
2142     const char type = mg->mg_type;
2143     if (type == PERL_MAGIC_qr) {
2144     } else if (type == PERL_MAGIC_bm) {
2145         SvTAIL_off(sv);
2146         SvVALID_off(sv);
2147     } else {
2148         assert(type == PERL_MAGIC_fm);
2149         SvCOMPILED_off(sv);
2150     }
2151     return sv_unmagic(sv, type);
2152 }
2153
2154 int
2155 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
2156 {
2157     dVAR;
2158     regexp * const re = (regexp *)mg->mg_obj;
2159     PERL_UNUSED_ARG(sv);
2160
2161     ReREFCNT_dec(re);
2162     return 0;
2163 }
2164
2165 #ifdef USE_LOCALE_COLLATE
2166 int
2167 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2168 {
2169     /*
2170      * RenE<eacute> Descartes said "I think not."
2171      * and vanished with a faint plop.
2172      */
2173     PERL_UNUSED_CONTEXT;
2174     PERL_UNUSED_ARG(sv);
2175     if (mg->mg_ptr) {
2176         Safefree(mg->mg_ptr);
2177         mg->mg_ptr = NULL;
2178         mg->mg_len = -1;
2179     }
2180     return 0;
2181 }
2182 #endif /* USE_LOCALE_COLLATE */
2183
2184 /* Just clear the UTF-8 cache data. */
2185 int
2186 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2187 {
2188     PERL_UNUSED_CONTEXT;
2189     PERL_UNUSED_ARG(sv);
2190     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2191     mg->mg_ptr = NULL;
2192     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2193     return 0;
2194 }
2195
2196 int
2197 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2198 {
2199     dVAR;
2200     register const char *s;
2201     register I32 paren;
2202     register const REGEXP * rx;
2203     const char * const remaining = mg->mg_ptr + 1;
2204     I32 i;
2205     STRLEN len;
2206
2207     switch (*mg->mg_ptr) {
2208     case '\015': /* $^MATCH */
2209       if (strEQ(remaining, "ATCH"))
2210           goto do_match;
2211     case '`': /* ${^PREMATCH} caught below */
2212       do_prematch:
2213       paren = RX_BUFF_IDX_PREMATCH;
2214       goto setparen;
2215     case '\'': /* ${^POSTMATCH} caught below */
2216       do_postmatch:
2217       paren = RX_BUFF_IDX_POSTMATCH;
2218       goto setparen;
2219     case '&':
2220       do_match:
2221       paren = RX_BUFF_IDX_FULLMATCH;
2222       goto setparen;
2223     case '1': case '2': case '3': case '4':
2224     case '5': case '6': case '7': case '8': case '9':
2225       paren = atoi(mg->mg_ptr);
2226       setparen:
2227         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2228             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2229             break;
2230         } else {
2231             /* Croak with a READONLY error when a numbered match var is
2232              * set without a previous pattern match. Unless it's C<local $1>
2233              */
2234             if (!PL_localizing) {
2235                 Perl_croak(aTHX_ PL_no_modify);
2236             }
2237         }
2238     case '\001':        /* ^A */
2239         sv_setsv(PL_bodytarget, sv);
2240         break;
2241     case '\003':        /* ^C */
2242         PL_minus_c = (bool)SvIV(sv);
2243         break;
2244
2245     case '\004':        /* ^D */
2246 #ifdef DEBUGGING
2247         s = SvPV_nolen_const(sv);
2248         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2249         DEBUG_x(dump_all());
2250 #else
2251         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2252 #endif
2253         break;
2254     case '\005':  /* ^E */
2255         if (*(mg->mg_ptr+1) == '\0') {
2256 #ifdef MACOS_TRADITIONAL
2257             gMacPerl_OSErr = SvIV(sv);
2258 #else
2259 #  ifdef VMS
2260             set_vaxc_errno(SvIV(sv));
2261 #  else
2262 #    ifdef WIN32
2263             SetLastError( SvIV(sv) );
2264 #    else
2265 #      ifdef OS2
2266             os2_setsyserrno(SvIV(sv));
2267 #      else
2268             /* will anyone ever use this? */
2269             SETERRNO(SvIV(sv), 4);
2270 #      endif
2271 #    endif
2272 #  endif
2273 #endif
2274         }
2275         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2276             if (PL_encoding)
2277                 SvREFCNT_dec(PL_encoding);
2278             if (SvOK(sv) || SvGMAGICAL(sv)) {
2279                 PL_encoding = newSVsv(sv);
2280             }
2281             else {
2282                 PL_encoding = NULL;
2283             }
2284         }
2285         break;
2286     case '\006':        /* ^F */
2287         PL_maxsysfd = SvIV(sv);
2288         break;
2289     case '\010':        /* ^H */
2290         PL_hints = SvIV(sv);
2291         break;
2292     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2293         Safefree(PL_inplace);
2294         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2295         break;
2296     case '\017':        /* ^O */
2297         if (*(mg->mg_ptr+1) == '\0') {
2298             Safefree(PL_osname);
2299             PL_osname = NULL;
2300             if (SvOK(sv)) {
2301                 TAINT_PROPER("assigning to $^O");
2302                 PL_osname = savesvpv(sv);
2303             }
2304         }
2305         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2306             STRLEN len;
2307             const char *const start = SvPV(sv, len);
2308             const char *out = (const char*)memchr(start, '\0', len);
2309             SV *tmp;
2310             struct refcounted_he *tmp_he;
2311
2312
2313             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2314             PL_hints
2315                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2316
2317             /* Opening for input is more common than opening for output, so
2318                ensure that hints for input are sooner on linked list.  */
2319             tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2320                              : newSVpvs(""));
2321             SvFLAGS(tmp) |= SvUTF8(sv);
2322
2323             tmp_he
2324                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2325                                          sv_2mortal(newSVpvs("open>")), tmp);
2326
2327             /* The UTF-8 setting is carried over  */
2328             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2329
2330             PL_compiling.cop_hints_hash
2331                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2332                                          sv_2mortal(newSVpvs("open<")), tmp);
2333         }
2334         break;
2335     case '\020':        /* ^P */
2336       if (*remaining == '\0') { /* ^P */
2337           PL_perldb = SvIV(sv);
2338           if (PL_perldb && !PL_DBsingle)
2339               init_debugger();
2340           break;
2341       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2342           goto do_prematch;
2343       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2344           goto do_postmatch;
2345       }
2346     case '\024':        /* ^T */
2347 #ifdef BIG_TIME
2348         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2349 #else
2350         PL_basetime = (Time_t)SvIV(sv);
2351 #endif
2352         break;
2353     case '\025':        /* ^UTF8CACHE */
2354          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2355              PL_utf8cache = (signed char) sv_2iv(sv);
2356          }
2357          break;
2358     case '\027':        /* ^W & $^WARNING_BITS */
2359         if (*(mg->mg_ptr+1) == '\0') {
2360             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2361                 i = SvIV(sv);
2362                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2363                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2364             }
2365         }
2366         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2367             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2368                 if (!SvPOK(sv) && PL_localizing) {
2369                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2370                     PL_compiling.cop_warnings = pWARN_NONE;
2371                     break;
2372                 }
2373                 {
2374                     STRLEN len, i;
2375                     int accumulate = 0 ;
2376                     int any_fatals = 0 ;
2377                     const char * const ptr = SvPV_const(sv, len) ;
2378                     for (i = 0 ; i < len ; ++i) {
2379                         accumulate |= ptr[i] ;
2380                         any_fatals |= (ptr[i] & 0xAA) ;
2381                     }
2382                     if (!accumulate) {
2383                         if (!specialWARN(PL_compiling.cop_warnings))
2384                             PerlMemShared_free(PL_compiling.cop_warnings);
2385                         PL_compiling.cop_warnings = pWARN_NONE;
2386                     }
2387                     /* Yuck. I can't see how to abstract this:  */
2388                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2389                                        WARN_ALL) && !any_fatals) {
2390                         if (!specialWARN(PL_compiling.cop_warnings))
2391                             PerlMemShared_free(PL_compiling.cop_warnings);
2392                         PL_compiling.cop_warnings = pWARN_ALL;
2393                         PL_dowarn |= G_WARN_ONCE ;
2394                     }
2395                     else {
2396                         STRLEN len;
2397                         const char *const p = SvPV_const(sv, len);
2398
2399                         PL_compiling.cop_warnings
2400                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2401                                                          p, len);
2402
2403                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2404                             PL_dowarn |= G_WARN_ONCE ;
2405                     }
2406
2407                 }
2408             }
2409         }
2410         break;
2411     case '.':
2412         if (PL_localizing) {
2413             if (PL_localizing == 1)
2414                 SAVESPTR(PL_last_in_gv);
2415         }
2416         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2417             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2418         break;
2419     case '^':
2420         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2421         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2422         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2423         break;
2424     case '~':
2425         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2426         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2427         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2428         break;
2429     case '=':
2430         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2431         break;
2432     case '-':
2433         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2434         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2435             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2436         break;
2437     case '%':
2438         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2439         break;
2440     case '|':
2441         {
2442             IO * const io = GvIOp(PL_defoutgv);
2443             if(!io)
2444               break;
2445             if ((SvIV(sv)) == 0)
2446                 IoFLAGS(io) &= ~IOf_FLUSH;
2447             else {
2448                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2449                     PerlIO *ofp = IoOFP(io);
2450                     if (ofp)
2451                         (void)PerlIO_flush(ofp);
2452                     IoFLAGS(io) |= IOf_FLUSH;
2453                 }
2454             }
2455         }
2456         break;
2457     case '/':
2458         SvREFCNT_dec(PL_rs);
2459         PL_rs = newSVsv(sv);
2460         break;
2461     case '\\':
2462         if (PL_ors_sv)
2463             SvREFCNT_dec(PL_ors_sv);
2464         if (SvOK(sv) || SvGMAGICAL(sv)) {
2465             PL_ors_sv = newSVsv(sv);
2466         }
2467         else {
2468             PL_ors_sv = NULL;
2469         }
2470         break;
2471     case ',':
2472         if (PL_ofs_sv)
2473             SvREFCNT_dec(PL_ofs_sv);
2474         if (SvOK(sv) || SvGMAGICAL(sv)) {
2475             PL_ofs_sv = newSVsv(sv);
2476         }
2477         else {
2478             PL_ofs_sv = NULL;
2479         }
2480         break;
2481     case '[':
2482         CopARYBASE_set(&PL_compiling, SvIV(sv));
2483         break;
2484     case '?':
2485 #ifdef COMPLEX_STATUS
2486         if (PL_localizing == 2) {
2487             PL_statusvalue = LvTARGOFF(sv);
2488             PL_statusvalue_vms = LvTARGLEN(sv);
2489         }
2490         else
2491 #endif
2492 #ifdef VMSISH_STATUS
2493         if (VMSISH_STATUS)
2494             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2495         else
2496 #endif
2497             STATUS_UNIX_EXIT_SET(SvIV(sv));
2498         break;
2499     case '!':
2500         {
2501 #ifdef VMS
2502 #   define PERL_VMS_BANG vaxc$errno
2503 #else
2504 #   define PERL_VMS_BANG 0
2505 #endif
2506         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2507                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2508         }
2509         break;
2510     case '<':
2511         PL_uid = SvIV(sv);
2512         if (PL_delaymagic) {
2513             PL_delaymagic |= DM_RUID;
2514             break;                              /* don't do magic till later */
2515         }
2516 #ifdef HAS_SETRUID
2517         (void)setruid((Uid_t)PL_uid);
2518 #else
2519 #ifdef HAS_SETREUID
2520         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2521 #else
2522 #ifdef HAS_SETRESUID
2523       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2524 #else
2525         if (PL_uid == PL_euid) {                /* special case $< = $> */
2526 #ifdef PERL_DARWIN
2527             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2528             if (PL_uid != 0 && PerlProc_getuid() == 0)
2529                 (void)PerlProc_setuid(0);
2530 #endif
2531             (void)PerlProc_setuid(PL_uid);
2532         } else {
2533             PL_uid = PerlProc_getuid();
2534             Perl_croak(aTHX_ "setruid() not implemented");
2535         }
2536 #endif
2537 #endif
2538 #endif
2539         PL_uid = PerlProc_getuid();
2540         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2541         break;
2542     case '>':
2543         PL_euid = SvIV(sv);
2544         if (PL_delaymagic) {
2545             PL_delaymagic |= DM_EUID;
2546             break;                              /* don't do magic till later */
2547         }
2548 #ifdef HAS_SETEUID
2549         (void)seteuid((Uid_t)PL_euid);
2550 #else
2551 #ifdef HAS_SETREUID
2552         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2553 #else
2554 #ifdef HAS_SETRESUID
2555         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2556 #else
2557         if (PL_euid == PL_uid)          /* special case $> = $< */
2558             PerlProc_setuid(PL_euid);
2559         else {
2560             PL_euid = PerlProc_geteuid();
2561             Perl_croak(aTHX_ "seteuid() not implemented");
2562         }
2563 #endif
2564 #endif
2565 #endif
2566         PL_euid = PerlProc_geteuid();
2567         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2568         break;
2569     case '(':
2570         PL_gid = SvIV(sv);
2571         if (PL_delaymagic) {
2572             PL_delaymagic |= DM_RGID;
2573             break;                              /* don't do magic till later */
2574         }
2575 #ifdef HAS_SETRGID
2576         (void)setrgid((Gid_t)PL_gid);
2577 #else
2578 #ifdef HAS_SETREGID
2579         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2580 #else
2581 #ifdef HAS_SETRESGID
2582       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2583 #else
2584         if (PL_gid == PL_egid)                  /* special case $( = $) */
2585             (void)PerlProc_setgid(PL_gid);
2586         else {
2587             PL_gid = PerlProc_getgid();
2588             Perl_croak(aTHX_ "setrgid() not implemented");
2589         }
2590 #endif
2591 #endif
2592 #endif
2593         PL_gid = PerlProc_getgid();
2594         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2595         break;
2596     case ')':
2597 #ifdef HAS_SETGROUPS
2598         {
2599             const char *p = SvPV_const(sv, len);
2600             Groups_t *gary = NULL;
2601
2602             while (isSPACE(*p))
2603                 ++p;
2604             PL_egid = Atol(p);
2605             for (i = 0; i < NGROUPS; ++i) {
2606                 while (*p && !isSPACE(*p))
2607                     ++p;
2608                 while (isSPACE(*p))
2609                     ++p;
2610                 if (!*p)
2611                     break;
2612                 if(!gary)
2613                     Newx(gary, i + 1, Groups_t);
2614                 else
2615                     Renew(gary, i + 1, Groups_t);
2616                 gary[i] = Atol(p);
2617             }
2618             if (i)
2619                 (void)setgroups(i, gary);
2620             Safefree(gary);
2621         }
2622 #else  /* HAS_SETGROUPS */
2623         PL_egid = SvIV(sv);
2624 #endif /* HAS_SETGROUPS */
2625         if (PL_delaymagic) {
2626             PL_delaymagic |= DM_EGID;
2627             break;                              /* don't do magic till later */
2628         }
2629 #ifdef HAS_SETEGID
2630         (void)setegid((Gid_t)PL_egid);
2631 #else
2632 #ifdef HAS_SETREGID
2633         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2634 #else
2635 #ifdef HAS_SETRESGID
2636         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2637 #else
2638         if (PL_egid == PL_gid)                  /* special case $) = $( */
2639             (void)PerlProc_setgid(PL_egid);
2640         else {
2641             PL_egid = PerlProc_getegid();
2642             Perl_croak(aTHX_ "setegid() not implemented");
2643         }
2644 #endif
2645 #endif
2646 #endif
2647         PL_egid = PerlProc_getegid();
2648         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2649         break;
2650     case ':':
2651         PL_chopset = SvPV_force(sv,len);
2652         break;
2653 #ifndef MACOS_TRADITIONAL
2654     case '0':
2655         LOCK_DOLLARZERO_MUTEX;
2656 #ifdef HAS_SETPROCTITLE
2657         /* The BSDs don't show the argv[] in ps(1) output, they
2658          * show a string from the process struct and provide
2659          * the setproctitle() routine to manipulate that. */
2660         if (PL_origalen != 1) {
2661             s = SvPV_const(sv, len);
2662 #   if __FreeBSD_version > 410001
2663             /* The leading "-" removes the "perl: " prefix,
2664              * but not the "(perl) suffix from the ps(1)
2665              * output, because that's what ps(1) shows if the
2666              * argv[] is modified. */
2667             setproctitle("-%s", s);
2668 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2669             /* This doesn't really work if you assume that
2670              * $0 = 'foobar'; will wipe out 'perl' from the $0
2671              * because in ps(1) output the result will be like
2672              * sprintf("perl: %s (perl)", s)
2673              * I guess this is a security feature:
2674              * one (a user process) cannot get rid of the original name.
2675              * --jhi */
2676             setproctitle("%s", s);
2677 #   endif
2678         }
2679 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2680         if (PL_origalen != 1) {
2681              union pstun un;
2682              s = SvPV_const(sv, len);
2683              un.pst_command = (char *)s;
2684              pstat(PSTAT_SETCMD, un, len, 0, 0);
2685         }
2686 #else
2687         if (PL_origalen > 1) {
2688             /* PL_origalen is set in perl_parse(). */
2689             s = SvPV_force(sv,len);
2690             if (len >= (STRLEN)PL_origalen-1) {
2691                 /* Longer than original, will be truncated. We assume that
2692                  * PL_origalen bytes are available. */
2693                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2694             }
2695             else {
2696                 /* Shorter than original, will be padded. */
2697 #ifdef PERL_DARWIN
2698                 /* Special case for Mac OS X: see [perl #38868] */
2699                 const int pad = 0;
2700 #else
2701                 /* Is the space counterintuitive?  Yes.
2702                  * (You were expecting \0?)
2703                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2704                  * --jhi */
2705                 const int pad = ' ';
2706 #endif
2707                 Copy(s, PL_origargv[0], len, char);
2708                 PL_origargv[0][len] = 0;
2709                 memset(PL_origargv[0] + len + 1,
2710                        pad,  PL_origalen - len - 1);
2711             }
2712             PL_origargv[0][PL_origalen-1] = 0;
2713             for (i = 1; i < PL_origargc; i++)
2714                 PL_origargv[i] = 0;
2715         }
2716 #endif
2717         UNLOCK_DOLLARZERO_MUTEX;
2718         break;
2719 #endif
2720     }
2721     return 0;
2722 }
2723
2724 I32
2725 Perl_whichsig(pTHX_ const char *sig)
2726 {
2727     register char* const* sigv;
2728     PERL_UNUSED_CONTEXT;
2729
2730     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2731         if (strEQ(sig,*sigv))
2732             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2733 #ifdef SIGCLD
2734     if (strEQ(sig,"CHLD"))
2735         return SIGCLD;
2736 #endif
2737 #ifdef SIGCHLD
2738     if (strEQ(sig,"CLD"))
2739         return SIGCHLD;
2740 #endif
2741     return -1;
2742 }
2743
2744 Signal_t
2745 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2746 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2747 #else
2748 Perl_sighandler(int sig)
2749 #endif
2750 {
2751 #ifdef PERL_GET_SIG_CONTEXT
2752     dTHXa(PERL_GET_SIG_CONTEXT);
2753 #else
2754     dTHX;
2755 #endif
2756     dSP;
2757     GV *gv = NULL;
2758     SV *sv = NULL;
2759     SV * const tSv = PL_Sv;
2760     CV *cv = NULL;
2761     OP *myop = PL_op;
2762     U32 flags = 0;
2763     XPV * const tXpv = PL_Xpv;
2764
2765     if (PL_savestack_ix + 15 <= PL_savestack_max)
2766         flags |= 1;
2767     if (PL_markstack_ptr < PL_markstack_max - 2)
2768         flags |= 4;
2769     if (PL_scopestack_ix < PL_scopestack_max - 3)
2770         flags |= 16;
2771
2772     if (!PL_psig_ptr[sig]) {
2773                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2774                                  PL_sig_name[sig]);
2775                 exit(sig);
2776         }
2777
2778     /* Max number of items pushed there is 3*n or 4. We cannot fix
2779        infinity, so we fix 4 (in fact 5): */
2780     if (flags & 1) {
2781         PL_savestack_ix += 5;           /* Protect save in progress. */
2782         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2783     }
2784     if (flags & 4)
2785         PL_markstack_ptr++;             /* Protect mark. */
2786     if (flags & 16)
2787         PL_scopestack_ix += 1;
2788     /* sv_2cv is too complicated, try a simpler variant first: */
2789     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2790         || SvTYPE(cv) != SVt_PVCV) {
2791         HV *st;
2792         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2793     }
2794
2795     if (!cv || !CvROOT(cv)) {
2796         if (ckWARN(WARN_SIGNAL))
2797             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2798                 PL_sig_name[sig], (gv ? GvENAME(gv)
2799                                 : ((cv && CvGV(cv))
2800                                    ? GvENAME(CvGV(cv))
2801                                    : "__ANON__")));
2802         goto cleanup;
2803     }
2804
2805     if(PL_psig_name[sig]) {
2806         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2807         flags |= 64;
2808 #if !defined(PERL_IMPLICIT_CONTEXT)
2809         PL_sig_sv = sv;
2810 #endif
2811     } else {
2812         sv = sv_newmortal();
2813         sv_setpv(sv,PL_sig_name[sig]);
2814     }
2815
2816     PUSHSTACKi(PERLSI_SIGNAL);
2817     PUSHMARK(SP);
2818     PUSHs(sv);
2819 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2820     {
2821          struct sigaction oact;
2822
2823          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2824               if (sip) {
2825                    HV *sih = newHV();
2826                    SV *rv  = newRV_noinc((SV*)sih);
2827                    /* The siginfo fields signo, code, errno, pid, uid,
2828                     * addr, status, and band are defined by POSIX/SUSv3. */
2829                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2830                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
2831 #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. */
2832                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
2833                    hv_stores(sih, "status",     newSViv(sip->si_status));
2834                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
2835                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
2836                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
2837                    hv_stores(sih, "band",       newSViv(sip->si_band));
2838 #endif
2839                    EXTEND(SP, 2);
2840                    PUSHs((SV*)rv);
2841                    PUSHs(newSVpvn((char *)sip, sizeof(*sip)));
2842               }
2843
2844          }
2845     }
2846 #endif
2847     PUTBACK;
2848
2849     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2850
2851     POPSTACK;
2852     if (SvTRUE(ERRSV)) {
2853 #ifndef PERL_MICRO
2854 #ifdef HAS_SIGPROCMASK
2855         /* Handler "died", for example to get out of a restart-able read().
2856          * Before we re-do that on its behalf re-enable the signal which was
2857          * blocked by the system when we entered.
2858          */
2859         sigset_t set;
2860         sigemptyset(&set);
2861         sigaddset(&set,sig);
2862         sigprocmask(SIG_UNBLOCK, &set, NULL);
2863 #else
2864         /* Not clear if this will work */
2865         (void)rsignal(sig, SIG_IGN);
2866         (void)rsignal(sig, PL_csighandlerp);
2867 #endif
2868 #endif /* !PERL_MICRO */
2869         Perl_die(aTHX_ NULL);
2870     }
2871 cleanup:
2872     if (flags & 1)
2873         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2874     if (flags & 4)
2875         PL_markstack_ptr--;
2876     if (flags & 16)
2877         PL_scopestack_ix -= 1;
2878     if (flags & 64)
2879         SvREFCNT_dec(sv);
2880     PL_op = myop;                       /* Apparently not needed... */
2881
2882     PL_Sv = tSv;                        /* Restore global temporaries. */
2883     PL_Xpv = tXpv;
2884     return;
2885 }
2886
2887
2888 static void
2889 S_restore_magic(pTHX_ const void *p)
2890 {
2891     dVAR;
2892     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2893     SV* const sv = mgs->mgs_sv;
2894
2895     if (!sv)
2896         return;
2897
2898     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2899     {
2900 #ifdef PERL_OLD_COPY_ON_WRITE
2901         /* While magic was saved (and off) sv_setsv may well have seen
2902            this SV as a prime candidate for COW.  */
2903         if (SvIsCOW(sv))
2904             sv_force_normal_flags(sv, 0);
2905 #endif
2906
2907         if (mgs->mgs_flags)
2908             SvFLAGS(sv) |= mgs->mgs_flags;
2909         else
2910             mg_magical(sv);
2911         if (SvGMAGICAL(sv)) {
2912             /* downgrade public flags to private,
2913                and discard any other private flags */
2914
2915             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2916             if (pubflags) {
2917                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2918                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2919             }
2920         }
2921     }
2922
2923     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2924
2925     /* If we're still on top of the stack, pop us off.  (That condition
2926      * will be satisfied if restore_magic was called explicitly, but *not*
2927      * if it's being called via leave_scope.)
2928      * The reason for doing this is that otherwise, things like sv_2cv()
2929      * may leave alloc gunk on the savestack, and some code
2930      * (e.g. sighandler) doesn't expect that...
2931      */
2932     if (PL_savestack_ix == mgs->mgs_ss_ix)
2933     {
2934         I32 popval = SSPOPINT;
2935         assert(popval == SAVEt_DESTRUCTOR_X);
2936         PL_savestack_ix -= 2;
2937         popval = SSPOPINT;
2938         assert(popval == SAVEt_ALLOC);
2939         popval = SSPOPINT;
2940         PL_savestack_ix -= popval;
2941     }
2942
2943 }
2944
2945 static void
2946 S_unwind_handler_stack(pTHX_ const void *p)
2947 {
2948     dVAR;
2949     const U32 flags = *(const U32*)p;
2950
2951     if (flags & 1)
2952         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2953 #if !defined(PERL_IMPLICIT_CONTEXT)
2954     if (flags & 64)
2955         SvREFCNT_dec(PL_sig_sv);
2956 #endif
2957 }
2958
2959 /*
2960 =for apidoc magic_sethint
2961
2962 Triggered by a store to %^H, records the key/value pair to
2963 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
2964 anything that would need a deep copy.  Maybe we should warn if we find a
2965 reference.
2966
2967 =cut
2968 */
2969 int
2970 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2971 {
2972     dVAR;
2973     SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
2974         : sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len));
2975
2976     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
2977        an alternative leaf in there, with PL_compiling.cop_hints being used if
2978        it's NULL. If needed for threads, the alternative could lock a mutex,
2979        or take other more complex action.  */
2980
2981     /* Something changed in %^H, so it will need to be restored on scope exit.
2982        Doing this here saves a lot of doing it manually in perl code (and
2983        forgetting to do it, and consequent subtle errors.  */
2984     PL_hints |= HINT_LOCALIZE_HH;
2985     PL_compiling.cop_hints_hash
2986         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
2987     return 0;
2988 }
2989
2990 /*
2991 =for apidoc magic_sethint
2992
2993 Triggered by a delete from %^H, records the key to
2994 C<PL_compiling.cop_hints_hash>.
2995
2996 =cut
2997 */
2998 int
2999 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3000 {
3001     dVAR;
3002     PERL_UNUSED_ARG(sv);
3003
3004     assert(mg->mg_len == HEf_SVKEY);
3005
3006     PERL_UNUSED_ARG(sv);
3007
3008     PL_hints |= HINT_LOCALIZE_HH;
3009     PL_compiling.cop_hints_hash
3010         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3011                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
3012     return 0;
3013 }
3014
3015 /*
3016  * Local variables:
3017  * c-indentation-style: bsd
3018  * c-basic-offset: 4
3019  * indent-tabs-mode: t
3020  * End:
3021  *
3022  * ex: set ts=8 sts=4 sw=4 noet:
3023  */