mg.c

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