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