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