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