mg.c

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