mg.c

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