mg.c

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