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