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       paren = atoi(mg->mg_ptr);
2246       setparen:
2247         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2248             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2249             break;
2250         } else {
2251             /* Croak with a READONLY error when a numbered match var is
2252              * set without a previous pattern match. Unless it's C<local $1>
2253              */
2254             if (!PL_localizing) {
2255                 Perl_croak(aTHX_ PL_no_modify);
2256             }
2257         }
2258     case '\001':        /* ^A */
2259         sv_setsv(PL_bodytarget, sv);
2260         break;
2261     case '\003':        /* ^C */
2262         PL_minus_c = (bool)SvIV(sv);
2263         break;
2264
2265     case '\004':        /* ^D */
2266 #ifdef DEBUGGING
2267         s = SvPV_nolen_const(sv);
2268         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2269         DEBUG_x(dump_all());
2270 #else
2271         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2272 #endif
2273         break;
2274     case '\005':  /* ^E */
2275         if (*(mg->mg_ptr+1) == '\0') {
2276 #ifdef MACOS_TRADITIONAL
2277             gMacPerl_OSErr = SvIV(sv);
2278 #else
2279 #  ifdef VMS
2280             set_vaxc_errno(SvIV(sv));
2281 #  else
2282 #    ifdef WIN32
2283             SetLastError( SvIV(sv) );
2284 #    else
2285 #      ifdef OS2
2286             os2_setsyserrno(SvIV(sv));
2287 #      else
2288             /* will anyone ever use this? */
2289             SETERRNO(SvIV(sv), 4);
2290 #      endif
2291 #    endif
2292 #  endif
2293 #endif
2294         }
2295         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2296             if (PL_encoding)
2297                 SvREFCNT_dec(PL_encoding);
2298             if (SvOK(sv) || SvGMAGICAL(sv)) {
2299                 PL_encoding = newSVsv(sv);
2300             }
2301             else {
2302                 PL_encoding = NULL;
2303             }
2304         }
2305         break;
2306     case '\006':        /* ^F */
2307         PL_maxsysfd = SvIV(sv);
2308         break;
2309     case '\010':        /* ^H */
2310         PL_hints = SvIV(sv);
2311         break;
2312     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2313         Safefree(PL_inplace);
2314         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2315         break;
2316     case '\017':        /* ^O */
2317         if (*(mg->mg_ptr+1) == '\0') {
2318             Safefree(PL_osname);
2319             PL_osname = NULL;
2320             if (SvOK(sv)) {
2321                 TAINT_PROPER("assigning to $^O");
2322                 PL_osname = savesvpv(sv);
2323             }
2324         }
2325         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2326             STRLEN len;
2327             const char *const start = SvPV(sv, len);
2328             const char *out = (const char*)memchr(start, '\0', len);
2329             SV *tmp;
2330             struct refcounted_he *tmp_he;
2331
2332
2333             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2334             PL_hints
2335                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2336
2337             /* Opening for input is more common than opening for output, so
2338                ensure that hints for input are sooner on linked list.  */
2339             tmp = sv_2mortal(out ? newSVpvn(out + 1, start + len - out - 1)
2340                              : newSVpvs(""));
2341             SvFLAGS(tmp) |= SvUTF8(sv);
2342
2343             tmp_he
2344                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2345                                          sv_2mortal(newSVpvs("open>")), tmp);
2346
2347             /* The UTF-8 setting is carried over  */
2348             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2349
2350             PL_compiling.cop_hints_hash
2351                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2352                                          sv_2mortal(newSVpvs("open<")), tmp);
2353         }
2354         break;
2355     case '\020':        /* ^P */
2356       if (*remaining == '\0') { /* ^P */
2357           PL_perldb = SvIV(sv);
2358           if (PL_perldb && !PL_DBsingle)
2359               init_debugger();
2360           break;
2361       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2362           goto do_prematch;
2363       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2364           goto do_postmatch;
2365       }
2366     case '\024':        /* ^T */
2367 #ifdef BIG_TIME
2368         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2369 #else
2370         PL_basetime = (Time_t)SvIV(sv);
2371 #endif
2372         break;
2373     case '\025':        /* ^UTF8CACHE */
2374          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2375              PL_utf8cache = (signed char) sv_2iv(sv);
2376          }
2377          break;
2378     case '\027':        /* ^W & $^WARNING_BITS */
2379         if (*(mg->mg_ptr+1) == '\0') {
2380             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2381                 i = SvIV(sv);
2382                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2383                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2384             }
2385         }
2386         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2387             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2388                 if (!SvPOK(sv) && PL_localizing) {
2389                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2390                     PL_compiling.cop_warnings = pWARN_NONE;
2391                     break;
2392                 }
2393                 {
2394                     STRLEN len, i;
2395                     int accumulate = 0 ;
2396                     int any_fatals = 0 ;
2397                     const char * const ptr = SvPV_const(sv, len) ;
2398                     for (i = 0 ; i < len ; ++i) {
2399                         accumulate |= ptr[i] ;
2400                         any_fatals |= (ptr[i] & 0xAA) ;
2401                     }
2402                     if (!accumulate) {
2403                         if (!specialWARN(PL_compiling.cop_warnings))
2404                             PerlMemShared_free(PL_compiling.cop_warnings);
2405                         PL_compiling.cop_warnings = pWARN_NONE;
2406                     }
2407                     /* Yuck. I can't see how to abstract this:  */
2408                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2409                                        WARN_ALL) && !any_fatals) {
2410                         if (!specialWARN(PL_compiling.cop_warnings))
2411                             PerlMemShared_free(PL_compiling.cop_warnings);
2412                         PL_compiling.cop_warnings = pWARN_ALL;
2413                         PL_dowarn |= G_WARN_ONCE ;
2414                     }
2415                     else {
2416                         STRLEN len;
2417                         const char *const p = SvPV_const(sv, len);
2418
2419                         PL_compiling.cop_warnings
2420                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2421                                                          p, len);
2422
2423                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2424                             PL_dowarn |= G_WARN_ONCE ;
2425                     }
2426
2427                 }
2428             }
2429         }
2430         break;
2431     case '.':
2432         if (PL_localizing) {
2433             if (PL_localizing == 1)
2434                 SAVESPTR(PL_last_in_gv);
2435         }
2436         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2437             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2438         break;
2439     case '^':
2440         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2441         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2442         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2443         break;
2444     case '~':
2445         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2446         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2447         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2448         break;
2449     case '=':
2450         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2451         break;
2452     case '-':
2453         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2454         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2455             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2456         break;
2457     case '%':
2458         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2459         break;
2460     case '|':
2461         {
2462             IO * const io = GvIOp(PL_defoutgv);
2463             if(!io)
2464               break;
2465             if ((SvIV(sv)) == 0)
2466                 IoFLAGS(io) &= ~IOf_FLUSH;
2467             else {
2468                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2469                     PerlIO *ofp = IoOFP(io);
2470                     if (ofp)
2471                         (void)PerlIO_flush(ofp);
2472                     IoFLAGS(io) |= IOf_FLUSH;
2473                 }
2474             }
2475         }
2476         break;
2477     case '/':
2478         SvREFCNT_dec(PL_rs);
2479         PL_rs = newSVsv(sv);
2480         break;
2481     case '\\':
2482         if (PL_ors_sv)
2483             SvREFCNT_dec(PL_ors_sv);
2484         if (SvOK(sv) || SvGMAGICAL(sv)) {
2485             PL_ors_sv = newSVsv(sv);
2486         }
2487         else {
2488             PL_ors_sv = NULL;
2489         }
2490         break;
2491     case ',':
2492         if (PL_ofs_sv)
2493             SvREFCNT_dec(PL_ofs_sv);
2494         if (SvOK(sv) || SvGMAGICAL(sv)) {
2495             PL_ofs_sv = newSVsv(sv);
2496         }
2497         else {
2498             PL_ofs_sv = NULL;
2499         }
2500         break;
2501     case '[':
2502         CopARYBASE_set(&PL_compiling, SvIV(sv));
2503         break;
2504     case '?':
2505 #ifdef COMPLEX_STATUS
2506         if (PL_localizing == 2) {
2507             PL_statusvalue = LvTARGOFF(sv);
2508             PL_statusvalue_vms = LvTARGLEN(sv);
2509         }
2510         else
2511 #endif
2512 #ifdef VMSISH_STATUS
2513         if (VMSISH_STATUS)
2514             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2515         else
2516 #endif
2517             STATUS_UNIX_EXIT_SET(SvIV(sv));
2518         break;
2519     case '!':
2520         {
2521 #ifdef VMS
2522 #   define PERL_VMS_BANG vaxc$errno
2523 #else
2524 #   define PERL_VMS_BANG 0
2525 #endif
2526         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2527                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2528         }
2529         break;
2530     case '<':
2531         PL_uid = SvIV(sv);
2532         if (PL_delaymagic) {
2533             PL_delaymagic |= DM_RUID;
2534             break;                              /* don't do magic till later */
2535         }
2536 #ifdef HAS_SETRUID
2537         (void)setruid((Uid_t)PL_uid);
2538 #else
2539 #ifdef HAS_SETREUID
2540         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2541 #else
2542 #ifdef HAS_SETRESUID
2543       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2544 #else
2545         if (PL_uid == PL_euid) {                /* special case $< = $> */
2546 #ifdef PERL_DARWIN
2547             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2548             if (PL_uid != 0 && PerlProc_getuid() == 0)
2549                 (void)PerlProc_setuid(0);
2550 #endif
2551             (void)PerlProc_setuid(PL_uid);
2552         } else {
2553             PL_uid = PerlProc_getuid();
2554             Perl_croak(aTHX_ "setruid() not implemented");
2555         }
2556 #endif
2557 #endif
2558 #endif
2559         PL_uid = PerlProc_getuid();
2560         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2561         break;
2562     case '>':
2563         PL_euid = SvIV(sv);
2564         if (PL_delaymagic) {
2565             PL_delaymagic |= DM_EUID;
2566             break;                              /* don't do magic till later */
2567         }
2568 #ifdef HAS_SETEUID
2569         (void)seteuid((Uid_t)PL_euid);
2570 #else
2571 #ifdef HAS_SETREUID
2572         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2573 #else
2574 #ifdef HAS_SETRESUID
2575         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2576 #else
2577         if (PL_euid == PL_uid)          /* special case $> = $< */
2578             PerlProc_setuid(PL_euid);
2579         else {
2580             PL_euid = PerlProc_geteuid();
2581             Perl_croak(aTHX_ "seteuid() not implemented");
2582         }
2583 #endif
2584 #endif
2585 #endif
2586         PL_euid = PerlProc_geteuid();
2587         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2588         break;
2589     case '(':
2590         PL_gid = SvIV(sv);
2591         if (PL_delaymagic) {
2592             PL_delaymagic |= DM_RGID;
2593             break;                              /* don't do magic till later */
2594         }
2595 #ifdef HAS_SETRGID
2596         (void)setrgid((Gid_t)PL_gid);
2597 #else
2598 #ifdef HAS_SETREGID
2599         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2600 #else
2601 #ifdef HAS_SETRESGID
2602       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2603 #else
2604         if (PL_gid == PL_egid)                  /* special case $( = $) */
2605             (void)PerlProc_setgid(PL_gid);
2606         else {
2607             PL_gid = PerlProc_getgid();
2608             Perl_croak(aTHX_ "setrgid() not implemented");
2609         }
2610 #endif
2611 #endif
2612 #endif
2613         PL_gid = PerlProc_getgid();
2614         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2615         break;
2616     case ')':
2617 #ifdef HAS_SETGROUPS
2618         {
2619             const char *p = SvPV_const(sv, len);
2620             Groups_t *gary = NULL;
2621
2622             while (isSPACE(*p))
2623                 ++p;
2624             PL_egid = Atol(p);
2625             for (i = 0; i < NGROUPS; ++i) {
2626                 while (*p && !isSPACE(*p))
2627                     ++p;
2628                 while (isSPACE(*p))
2629                     ++p;
2630                 if (!*p)
2631                     break;
2632                 if(!gary)
2633                     Newx(gary, i + 1, Groups_t);
2634                 else
2635                     Renew(gary, i + 1, Groups_t);
2636                 gary[i] = Atol(p);
2637             }
2638             if (i)
2639                 (void)setgroups(i, gary);
2640             Safefree(gary);
2641         }
2642 #else  /* HAS_SETGROUPS */
2643         PL_egid = SvIV(sv);
2644 #endif /* HAS_SETGROUPS */
2645         if (PL_delaymagic) {
2646             PL_delaymagic |= DM_EGID;
2647             break;                              /* don't do magic till later */
2648         }
2649 #ifdef HAS_SETEGID
2650         (void)setegid((Gid_t)PL_egid);
2651 #else
2652 #ifdef HAS_SETREGID
2653         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2654 #else
2655 #ifdef HAS_SETRESGID
2656         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2657 #else
2658         if (PL_egid == PL_gid)                  /* special case $) = $( */
2659             (void)PerlProc_setgid(PL_egid);
2660         else {
2661             PL_egid = PerlProc_getegid();
2662             Perl_croak(aTHX_ "setegid() not implemented");
2663         }
2664 #endif
2665 #endif
2666 #endif
2667         PL_egid = PerlProc_getegid();
2668         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2669         break;
2670     case ':':
2671         PL_chopset = SvPV_force(sv,len);
2672         break;
2673 #ifndef MACOS_TRADITIONAL
2674     case '0':
2675         LOCK_DOLLARZERO_MUTEX;
2676 #ifdef HAS_SETPROCTITLE
2677         /* The BSDs don't show the argv[] in ps(1) output, they
2678          * show a string from the process struct and provide
2679          * the setproctitle() routine to manipulate that. */
2680         if (PL_origalen != 1) {
2681             s = SvPV_const(sv, len);
2682 #   if __FreeBSD_version > 410001
2683             /* The leading "-" removes the "perl: " prefix,
2684              * but not the "(perl) suffix from the ps(1)
2685              * output, because that's what ps(1) shows if the
2686              * argv[] is modified. */
2687             setproctitle("-%s", s);
2688 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2689             /* This doesn't really work if you assume that
2690              * $0 = 'foobar'; will wipe out 'perl' from the $0
2691              * because in ps(1) output the result will be like
2692              * sprintf("perl: %s (perl)", s)
2693              * I guess this is a security feature:
2694              * one (a user process) cannot get rid of the original name.
2695              * --jhi */
2696             setproctitle("%s", s);
2697 #   endif
2698         }
2699 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2700         if (PL_origalen != 1) {
2701              union pstun un;
2702              s = SvPV_const(sv, len);
2703              un.pst_command = (char *)s;
2704              pstat(PSTAT_SETCMD, un, len, 0, 0);
2705         }
2706 #else
2707         if (PL_origalen > 1) {
2708             /* PL_origalen is set in perl_parse(). */
2709             s = SvPV_force(sv,len);
2710             if (len >= (STRLEN)PL_origalen-1) {
2711                 /* Longer than original, will be truncated. We assume that
2712                  * PL_origalen bytes are available. */
2713                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2714             }
2715             else {
2716                 /* Shorter than original, will be padded. */
2717 #ifdef PERL_DARWIN
2718                 /* Special case for Mac OS X: see [perl #38868] */
2719                 const int pad = 0;
2720 #else
2721                 /* Is the space counterintuitive?  Yes.
2722                  * (You were expecting \0?)
2723                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2724                  * --jhi */
2725                 const int pad = ' ';
2726 #endif
2727                 Copy(s, PL_origargv[0], len, char);
2728                 PL_origargv[0][len] = 0;
2729                 memset(PL_origargv[0] + len + 1,
2730                        pad,  PL_origalen - len - 1);
2731             }
2732             PL_origargv[0][PL_origalen-1] = 0;
2733             for (i = 1; i < PL_origargc; i++)
2734                 PL_origargv[i] = 0;
2735         }
2736 #endif
2737         UNLOCK_DOLLARZERO_MUTEX;
2738         break;
2739 #endif
2740     }
2741     return 0;
2742 }
2743
2744 I32
2745 Perl_whichsig(pTHX_ const char *sig)
2746 {
2747     register char* const* sigv;
2748     PERL_UNUSED_CONTEXT;
2749
2750     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2751         if (strEQ(sig,*sigv))
2752             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2753 #ifdef SIGCLD
2754     if (strEQ(sig,"CHLD"))
2755         return SIGCLD;
2756 #endif
2757 #ifdef SIGCHLD
2758     if (strEQ(sig,"CLD"))
2759         return SIGCHLD;
2760 #endif
2761     return -1;
2762 }
2763
2764 Signal_t
2765 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2766 Perl_sighandler(int sig, ...)
2767 #else
2768 Perl_sighandler(int sig)
2769 #endif
2770 {
2771 #ifdef PERL_GET_SIG_CONTEXT
2772     dTHXa(PERL_GET_SIG_CONTEXT);
2773 #else
2774     dTHX;
2775 #endif
2776     dSP;
2777     GV *gv = NULL;
2778     SV *sv = NULL;
2779     SV * const tSv = PL_Sv;
2780     CV *cv = NULL;
2781     OP *myop = PL_op;
2782     U32 flags = 0;
2783     XPV * const tXpv = PL_Xpv;
2784
2785     if (PL_savestack_ix + 15 <= PL_savestack_max)
2786         flags |= 1;
2787     if (PL_markstack_ptr < PL_markstack_max - 2)
2788         flags |= 4;
2789     if (PL_scopestack_ix < PL_scopestack_max - 3)
2790         flags |= 16;
2791
2792     if (!PL_psig_ptr[sig]) {
2793                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2794                                  PL_sig_name[sig]);
2795                 exit(sig);
2796         }
2797
2798     /* Max number of items pushed there is 3*n or 4. We cannot fix
2799        infinity, so we fix 4 (in fact 5): */
2800     if (flags & 1) {
2801         PL_savestack_ix += 5;           /* Protect save in progress. */
2802         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2803     }
2804     if (flags & 4)
2805         PL_markstack_ptr++;             /* Protect mark. */
2806     if (flags & 16)
2807         PL_scopestack_ix += 1;
2808     /* sv_2cv is too complicated, try a simpler variant first: */
2809     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2810         || SvTYPE(cv) != SVt_PVCV) {
2811         HV *st;
2812         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2813     }
2814
2815     if (!cv || !CvROOT(cv)) {
2816         if (ckWARN(WARN_SIGNAL))
2817             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2818                 PL_sig_name[sig], (gv ? GvENAME(gv)
2819                                 : ((cv && CvGV(cv))
2820                                    ? GvENAME(CvGV(cv))
2821                                    : "__ANON__")));
2822         goto cleanup;
2823     }
2824
2825     if(PL_psig_name[sig]) {
2826         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2827         flags |= 64;
2828 #if !defined(PERL_IMPLICIT_CONTEXT)
2829         PL_sig_sv = sv;
2830 #endif
2831     } else {
2832         sv = sv_newmortal();
2833         sv_setpv(sv,PL_sig_name[sig]);
2834     }
2835
2836     PUSHSTACKi(PERLSI_SIGNAL);
2837     PUSHMARK(SP);
2838     PUSHs(sv);
2839 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2840     {
2841          struct sigaction oact;
2842
2843          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2844               siginfo_t *sip;
2845               va_list args;
2846
2847               va_start(args, sig);
2848               sip = (siginfo_t*)va_arg(args, siginfo_t*);
2849               if (sip) {
2850                    HV *sih = newHV();
2851                    SV *rv  = newRV_noinc((SV*)sih);
2852                    /* The siginfo fields signo, code, errno, pid, uid,
2853                     * addr, status, and band are defined by POSIX/SUSv3. */
2854                    hv_store(sih, "signo",   5, newSViv(sip->si_signo),  0);
2855                    hv_store(sih, "code",    4, newSViv(sip->si_code),   0);
2856 #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. */
2857                    hv_store(sih, "errno",   5, newSViv(sip->si_errno),  0);
2858                    hv_store(sih, "status",  6, newSViv(sip->si_status), 0);
2859                    hv_store(sih, "uid",     3, newSViv(sip->si_uid),    0);
2860                    hv_store(sih, "pid",     3, newSViv(sip->si_pid),    0);
2861                    hv_store(sih, "addr",    4, newSVuv(PTR2UV(sip->si_addr)),   0);
2862                    hv_store(sih, "band",    4, newSViv(sip->si_band),   0);
2863 #endif
2864                    EXTEND(SP, 2);
2865                    PUSHs((SV*)rv);
2866                    PUSHs(newSVpv((char *)sip, sizeof(*sip)));
2867               }
2868
2869               va_end(args);
2870          }
2871     }
2872 #endif
2873     PUTBACK;
2874
2875     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2876
2877     POPSTACK;
2878     if (SvTRUE(ERRSV)) {
2879 #ifndef PERL_MICRO
2880 #ifdef HAS_SIGPROCMASK
2881         /* Handler "died", for example to get out of a restart-able read().
2882          * Before we re-do that on its behalf re-enable the signal which was
2883          * blocked by the system when we entered.
2884          */
2885         sigset_t set;
2886         sigemptyset(&set);
2887         sigaddset(&set,sig);
2888         sigprocmask(SIG_UNBLOCK, &set, NULL);
2889 #else
2890         /* Not clear if this will work */
2891         (void)rsignal(sig, SIG_IGN);
2892         (void)rsignal(sig, PL_csighandlerp);
2893 #endif
2894 #endif /* !PERL_MICRO */
2895         Perl_die(aTHX_ NULL);
2896     }
2897 cleanup:
2898     if (flags & 1)
2899         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2900     if (flags & 4)
2901         PL_markstack_ptr--;
2902     if (flags & 16)
2903         PL_scopestack_ix -= 1;
2904     if (flags & 64)
2905         SvREFCNT_dec(sv);
2906     PL_op = myop;                       /* Apparently not needed... */
2907
2908     PL_Sv = tSv;                        /* Restore global temporaries. */
2909     PL_Xpv = tXpv;
2910     return;
2911 }
2912
2913
2914 static void
2915 S_restore_magic(pTHX_ const void *p)
2916 {
2917     dVAR;
2918     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2919     SV* const sv = mgs->mgs_sv;
2920
2921     if (!sv)
2922         return;
2923
2924     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2925     {
2926 #ifdef PERL_OLD_COPY_ON_WRITE
2927         /* While magic was saved (and off) sv_setsv may well have seen
2928            this SV as a prime candidate for COW.  */
2929         if (SvIsCOW(sv))
2930             sv_force_normal_flags(sv, 0);
2931 #endif
2932
2933         if (mgs->mgs_flags)
2934             SvFLAGS(sv) |= mgs->mgs_flags;
2935         else
2936             mg_magical(sv);
2937         if (SvGMAGICAL(sv)) {
2938             /* downgrade public flags to private,
2939                and discard any other private flags */
2940
2941             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2942             if (pubflags) {
2943                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2944                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2945             }
2946         }
2947     }
2948
2949     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2950
2951     /* If we're still on top of the stack, pop us off.  (That condition
2952      * will be satisfied if restore_magic was called explicitly, but *not*
2953      * if it's being called via leave_scope.)
2954      * The reason for doing this is that otherwise, things like sv_2cv()
2955      * may leave alloc gunk on the savestack, and some code
2956      * (e.g. sighandler) doesn't expect that...
2957      */
2958     if (PL_savestack_ix == mgs->mgs_ss_ix)
2959     {
2960         I32 popval = SSPOPINT;
2961         assert(popval == SAVEt_DESTRUCTOR_X);
2962         PL_savestack_ix -= 2;
2963         popval = SSPOPINT;
2964         assert(popval == SAVEt_ALLOC);
2965         popval = SSPOPINT;
2966         PL_savestack_ix -= popval;
2967     }
2968
2969 }
2970
2971 static void
2972 S_unwind_handler_stack(pTHX_ const void *p)
2973 {
2974     dVAR;
2975     const U32 flags = *(const U32*)p;
2976
2977     if (flags & 1)
2978         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2979 #if !defined(PERL_IMPLICIT_CONTEXT)
2980     if (flags & 64)
2981         SvREFCNT_dec(PL_sig_sv);
2982 #endif
2983 }
2984
2985 /*
2986 =for apidoc magic_sethint
2987
2988 Triggered by a store to %^H, records the key/value pair to
2989 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
2990 anything that would need a deep copy.  Maybe we should warn if we find a
2991 reference.
2992
2993 =cut
2994 */
2995 int
2996 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
2997 {
2998     dVAR;
2999     assert(mg->mg_len == HEf_SVKEY);
3000
3001     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3002        an alternative leaf in there, with PL_compiling.cop_hints being used if
3003        it's NULL. If needed for threads, the alternative could lock a mutex,
3004        or take other more complex action.  */
3005
3006     /* Something changed in %^H, so it will need to be restored on scope exit.
3007        Doing this here saves a lot of doing it manually in perl code (and
3008        forgetting to do it, and consequent subtle errors.  */
3009     PL_hints |= HINT_LOCALIZE_HH;
3010     PL_compiling.cop_hints_hash
3011         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3012                                  (SV *)mg->mg_ptr, sv);
3013     return 0;
3014 }
3015
3016 /*
3017 =for apidoc magic_sethint
3018
3019 Triggered by a delete from %^H, records the key to
3020 C<PL_compiling.cop_hints_hash>.
3021
3022 =cut
3023 */
3024 int
3025 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3026 {
3027     dVAR;
3028     PERL_UNUSED_ARG(sv);
3029
3030     assert(mg->mg_len == HEf_SVKEY);
3031
3032     PERL_UNUSED_ARG(sv);
3033
3034     PL_hints |= HINT_LOCALIZE_HH;
3035     PL_compiling.cop_hints_hash
3036         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3037                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
3038     return 0;
3039 }
3040
3041 /*
3042  * Local variables:
3043  * c-indentation-style: bsd
3044  * c-basic-offset: 4
3045  * indent-tabs-mode: t
3046  * End:
3047  *
3048  * ex: set ts=8 sts=4 sw=4 noet:
3049  */