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