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