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