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