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