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