mg.c

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