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