mg.c

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