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 Signal_t
1333 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1334 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1335 #else
1336 Perl_csighandler(int sig)
1337 #endif
1338 {
1339 #ifdef PERL_GET_SIG_CONTEXT
1340     dTHXa(PERL_GET_SIG_CONTEXT);
1341 #else
1342     dTHX;
1343 #endif
1344 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1345     (void) rsignal(sig, PL_csighandlerp);
1346     if (PL_sig_ignoring[sig]) return;
1347 #endif
1348 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1349     if (PL_sig_defaulting[sig])
1350 #ifdef KILL_BY_SIGPRC
1351             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1352 #else
1353             exit(1);
1354 #endif
1355 #endif
1356     if (
1357 #ifdef SIGILL
1358            sig == SIGILL ||
1359 #endif
1360 #ifdef SIGBUS
1361            sig == SIGBUS ||
1362 #endif
1363 #ifdef SIGSEGV
1364            sig == SIGSEGV ||
1365 #endif
1366            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1367         /* Call the perl level handler now--
1368          * with risk we may be in malloc() etc. */
1369 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1370         (*PL_sighandlerp)(sig, NULL, NULL);
1371 #else
1372         (*PL_sighandlerp)(sig);
1373 #endif
1374     else {
1375         /* Set a flag to say this signal is pending, that is awaiting delivery after
1376          * the current Perl opcode completes */
1377         PL_psig_pend[sig]++;
1378
1379 #ifndef SIG_PENDING_DIE_COUNT
1380 #  define SIG_PENDING_DIE_COUNT 120
1381 #endif
1382         /* And one to say _a_ signal is pending */
1383         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1384             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1385                        (unsigned long)SIG_PENDING_DIE_COUNT);
1386     }
1387 }
1388
1389 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1390 void
1391 Perl_csighandler_init(void)
1392 {
1393     int sig;
1394     if (PL_sig_handlers_initted) return;
1395
1396     for (sig = 1; sig < SIG_SIZE; sig++) {
1397 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1398         dTHX;
1399         PL_sig_defaulting[sig] = 1;
1400         (void) rsignal(sig, PL_csighandlerp);
1401 #endif
1402 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1403         PL_sig_ignoring[sig] = 0;
1404 #endif
1405     }
1406     PL_sig_handlers_initted = 1;
1407 }
1408 #endif
1409
1410 void
1411 Perl_despatch_signals(pTHX)
1412 {
1413     dVAR;
1414     int sig;
1415     PL_sig_pending = 0;
1416     for (sig = 1; sig < SIG_SIZE; sig++) {
1417         if (PL_psig_pend[sig]) {
1418             PERL_BLOCKSIG_ADD(set, sig);
1419             PL_psig_pend[sig] = 0;
1420             PERL_BLOCKSIG_BLOCK(set);
1421 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1422             (*PL_sighandlerp)(sig, NULL, NULL);
1423 #else
1424             (*PL_sighandlerp)(sig);
1425 #endif
1426             PERL_BLOCKSIG_UNBLOCK(set);
1427         }
1428     }
1429 }
1430
1431 int
1432 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1433 {
1434     dVAR;
1435     I32 i;
1436     SV** svp = NULL;
1437     /* Need to be careful with SvREFCNT_dec(), because that can have side
1438      * effects (due to closures). We must make sure that the new disposition
1439      * is in place before it is called.
1440      */
1441     SV* to_dec = NULL;
1442     STRLEN len;
1443 #ifdef HAS_SIGPROCMASK
1444     sigset_t set, save;
1445     SV* save_sv;
1446 #endif
1447     register const char *s = MgPV_const(mg,len);
1448
1449     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1450
1451     if (*s == '_') {
1452         if (strEQ(s,"__DIE__"))
1453             svp = &PL_diehook;
1454         else if (strEQ(s,"__WARN__"))
1455             svp = &PL_warnhook;
1456         else
1457             Perl_croak(aTHX_ "No such hook: %s", s);
1458         i = 0;
1459         if (*svp) {
1460             if (*svp != PERL_WARNHOOK_FATAL)
1461                 to_dec = *svp;
1462             *svp = NULL;
1463         }
1464     }
1465     else {
1466         i = whichsig(s);        /* ...no, a brick */
1467         if (i <= 0) {
1468             if (ckWARN(WARN_SIGNAL))
1469                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1470             return 0;
1471         }
1472 #ifdef HAS_SIGPROCMASK
1473         /* Avoid having the signal arrive at a bad time, if possible. */
1474         sigemptyset(&set);
1475         sigaddset(&set,i);
1476         sigprocmask(SIG_BLOCK, &set, &save);
1477         ENTER;
1478         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1479         SAVEFREESV(save_sv);
1480         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1481 #endif
1482         PERL_ASYNC_CHECK();
1483 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1484         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1485 #endif
1486 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1487         PL_sig_ignoring[i] = 0;
1488 #endif
1489 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1490         PL_sig_defaulting[i] = 0;
1491 #endif
1492         SvREFCNT_dec(PL_psig_name[i]);
1493         to_dec = PL_psig_ptr[i];
1494         PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1495         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1496         PL_psig_name[i] = newSVpvn(s, len);
1497         SvREADONLY_on(PL_psig_name[i]);
1498     }
1499     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1500         if (i) {
1501             (void)rsignal(i, PL_csighandlerp);
1502 #ifdef HAS_SIGPROCMASK
1503             LEAVE;
1504 #endif
1505         }
1506         else
1507             *svp = SvREFCNT_inc_simple_NN(sv);
1508         if(to_dec)
1509             SvREFCNT_dec(to_dec);
1510         return 0;
1511     }
1512     s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
1513     if (strEQ(s,"IGNORE")) {
1514         if (i) {
1515 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1516             PL_sig_ignoring[i] = 1;
1517             (void)rsignal(i, PL_csighandlerp);
1518 #else
1519             (void)rsignal(i, (Sighandler_t) SIG_IGN);
1520 #endif
1521         }
1522     }
1523     else if (strEQ(s,"DEFAULT") || !*s) {
1524         if (i)
1525 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1526           {
1527             PL_sig_defaulting[i] = 1;
1528             (void)rsignal(i, PL_csighandlerp);
1529           }
1530 #else
1531             (void)rsignal(i, (Sighandler_t) SIG_DFL);
1532 #endif
1533     }
1534     else {
1535         /*
1536          * We should warn if HINT_STRICT_REFS, but without
1537          * access to a known hint bit in a known OP, we can't
1538          * tell whether HINT_STRICT_REFS is in force or not.
1539          */
1540         if (!strchr(s,':') && !strchr(s,'\''))
1541             Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1542                                  SV_GMAGIC);
1543         if (i)
1544             (void)rsignal(i, PL_csighandlerp);
1545         else
1546             *svp = SvREFCNT_inc_simple_NN(sv);
1547     }
1548 #ifdef HAS_SIGPROCMASK
1549     if(i)
1550         LEAVE;
1551 #endif
1552     if(to_dec)
1553         SvREFCNT_dec(to_dec);
1554     return 0;
1555 }
1556 #endif /* !PERL_MICRO */
1557
1558 int
1559 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1560 {
1561     dVAR;
1562     HV* stash;
1563
1564     PERL_ARGS_ASSERT_MAGIC_SETISA;
1565     PERL_UNUSED_ARG(sv);
1566
1567     /* Bail out if destruction is going on */
1568     if(PL_dirty) return 0;
1569
1570     /* Skip _isaelem because _isa will handle it shortly */
1571     if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1572         return 0;
1573
1574     /* XXX Once it's possible, we need to
1575        detect that our @ISA is aliased in
1576        other stashes, and act on the stashes
1577        of all of the aliases */
1578
1579     /* The first case occurs via setisa,
1580        the second via setisa_elem, which
1581        calls this same magic */
1582     stash = GvSTASH(
1583         SvTYPE(mg->mg_obj) == SVt_PVGV
1584             ? (GV*)mg->mg_obj
1585             : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1586     );
1587
1588     if (stash)
1589         mro_isa_changed_in(stash);
1590
1591     return 0;
1592 }
1593
1594 int
1595 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1596 {
1597     dVAR;
1598     HV* stash;
1599
1600     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1601
1602     /* Bail out if destruction is going on */
1603     if(PL_dirty) return 0;
1604
1605     av_clear((AV*)sv);
1606
1607     /* XXX see comments in magic_setisa */
1608     stash = GvSTASH(
1609         SvTYPE(mg->mg_obj) == SVt_PVGV
1610             ? (GV*)mg->mg_obj
1611             : (GV*)SvMAGIC(mg->mg_obj)->mg_obj
1612     );
1613
1614     if (stash)
1615         mro_isa_changed_in(stash);
1616
1617     return 0;
1618 }
1619
1620 int
1621 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1622 {
1623     dVAR;
1624     PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
1625     PERL_UNUSED_ARG(sv);
1626     PERL_UNUSED_ARG(mg);
1627     PL_amagic_generation++;
1628
1629     return 0;
1630 }
1631
1632 int
1633 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1634 {
1635     HV * const hv = (HV*)LvTARG(sv);
1636     I32 i = 0;
1637
1638     PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
1639     PERL_UNUSED_ARG(mg);
1640
1641     if (hv) {
1642          (void) hv_iterinit(hv);
1643          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1644              i = HvKEYS(hv);
1645          else {
1646              while (hv_iternext(hv))
1647                  i++;
1648          }
1649     }
1650
1651     sv_setiv(sv, (IV)i);
1652     return 0;
1653 }
1654
1655 int
1656 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1657 {
1658     PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
1659     PERL_UNUSED_ARG(mg);
1660     if (LvTARG(sv)) {
1661         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1662     }
1663     return 0;
1664 }
1665
1666 /* caller is responsible for stack switching/cleanup */
1667 STATIC int
1668 S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
1669 {
1670     dVAR;
1671     dSP;
1672
1673     PERL_ARGS_ASSERT_MAGIC_METHCALL;
1674
1675     PUSHMARK(SP);
1676     EXTEND(SP, n);
1677     PUSHs(SvTIED_obj(sv, mg));
1678     if (n > 1) {
1679         if (mg->mg_ptr) {
1680             if (mg->mg_len >= 0)
1681                 mPUSHp(mg->mg_ptr, mg->mg_len);
1682             else if (mg->mg_len == HEf_SVKEY)
1683                 PUSHs((SV*)mg->mg_ptr);
1684         }
1685         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1686             mPUSHi(mg->mg_len);
1687         }
1688     }
1689     if (n > 2) {
1690         PUSHs(val);
1691     }
1692     PUTBACK;
1693
1694     return call_method(meth, flags);
1695 }
1696
1697 STATIC int
1698 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
1699 {
1700     dVAR; dSP;
1701
1702     PERL_ARGS_ASSERT_MAGIC_METHPACK;
1703
1704     ENTER;
1705     SAVETMPS;
1706     PUSHSTACKi(PERLSI_MAGIC);
1707
1708     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1709         sv_setsv(sv, *PL_stack_sp--);
1710     }
1711
1712     POPSTACK;
1713     FREETMPS;
1714     LEAVE;
1715     return 0;
1716 }
1717
1718 int
1719 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1720 {
1721     PERL_ARGS_ASSERT_MAGIC_GETPACK;
1722
1723     if (mg->mg_ptr)
1724         mg->mg_flags |= MGf_GSKIP;
1725     magic_methpack(sv,mg,"FETCH");
1726     return 0;
1727 }
1728
1729 int
1730 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1731 {
1732     dVAR; dSP;
1733
1734     PERL_ARGS_ASSERT_MAGIC_SETPACK;
1735
1736     ENTER;
1737     PUSHSTACKi(PERLSI_MAGIC);
1738     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1739     POPSTACK;
1740     LEAVE;
1741     return 0;
1742 }
1743
1744 int
1745 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1746 {
1747     PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
1748
1749     return magic_methpack(sv,mg,"DELETE");
1750 }
1751
1752
1753 U32
1754 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1755 {
1756     dVAR; dSP;
1757     I32 retval = 0;
1758
1759     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
1760
1761     ENTER;
1762     SAVETMPS;
1763     PUSHSTACKi(PERLSI_MAGIC);
1764     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1765         sv = *PL_stack_sp--;
1766         retval = SvIV(sv)-1;
1767         if (retval < -1)
1768             Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
1769     }
1770     POPSTACK;
1771     FREETMPS;
1772     LEAVE;
1773     return (U32) retval;
1774 }
1775
1776 int
1777 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1778 {
1779     dVAR; dSP;
1780
1781     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
1782
1783     ENTER;
1784     PUSHSTACKi(PERLSI_MAGIC);
1785     PUSHMARK(SP);
1786     XPUSHs(SvTIED_obj(sv, mg));
1787     PUTBACK;
1788     call_method("CLEAR", G_SCALAR|G_DISCARD);
1789     POPSTACK;
1790     LEAVE;
1791
1792     return 0;
1793 }
1794
1795 int
1796 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1797 {
1798     dVAR; dSP;
1799     const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1800
1801     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
1802
1803     ENTER;
1804     SAVETMPS;
1805     PUSHSTACKi(PERLSI_MAGIC);
1806     PUSHMARK(SP);
1807     EXTEND(SP, 2);
1808     PUSHs(SvTIED_obj(sv, mg));
1809     if (SvOK(key))
1810         PUSHs(key);
1811     PUTBACK;
1812
1813     if (call_method(meth, G_SCALAR))
1814         sv_setsv(key, *PL_stack_sp--);
1815
1816     POPSTACK;
1817     FREETMPS;
1818     LEAVE;
1819     return 0;
1820 }
1821
1822 int
1823 Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
1824 {
1825     PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
1826
1827     return magic_methpack(sv,mg,"EXISTS");
1828 }
1829
1830 SV *
1831 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
1832 {
1833     dVAR; dSP;
1834     SV *retval;
1835     SV * const tied = SvTIED_obj((SV*)hv, mg);
1836     HV * const pkg = SvSTASH((SV*)SvRV(tied));
1837
1838     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
1839
1840     if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
1841         SV *key;
1842         if (HvEITER_get(hv))
1843             /* we are in an iteration so the hash cannot be empty */
1844             return &PL_sv_yes;
1845         /* no xhv_eiter so now use FIRSTKEY */
1846         key = sv_newmortal();
1847         magic_nextpack((SV*)hv, mg, key);
1848         HvEITER_set(hv, NULL);     /* need to reset iterator */
1849         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
1850     }
1851
1852     /* there is a SCALAR method that we can call */
1853     ENTER;
1854     PUSHSTACKi(PERLSI_MAGIC);
1855     PUSHMARK(SP);
1856     EXTEND(SP, 1);
1857     PUSHs(tied);
1858     PUTBACK;
1859
1860     if (call_method("SCALAR", G_SCALAR))
1861         retval = *PL_stack_sp--;
1862     else
1863         retval = &PL_sv_undef;
1864     POPSTACK;
1865     LEAVE;
1866     return retval;
1867 }
1868
1869 int
1870 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1871 {
1872     dVAR;
1873     GV * const gv = PL_DBline;
1874     const I32 i = SvTRUE(sv);
1875     SV ** const svp = av_fetch(GvAV(gv),
1876                      atoi(MgPV_nolen_const(mg)), FALSE);
1877
1878     PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
1879
1880     if (svp && SvIOKp(*svp)) {
1881         OP * const o = INT2PTR(OP*,SvIVX(*svp));
1882         if (o) {
1883             /* set or clear breakpoint in the relevant control op */
1884             if (i)
1885                 o->op_flags |= OPf_SPECIAL;
1886             else
1887                 o->op_flags &= ~OPf_SPECIAL;
1888         }
1889     }
1890     return 0;
1891 }
1892
1893 int
1894 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
1895 {
1896     dVAR;
1897     const AV * const obj = (AV*)mg->mg_obj;
1898
1899     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
1900
1901     if (obj) {
1902         sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
1903     } else {
1904         SvOK_off(sv);
1905     }
1906     return 0;
1907 }
1908
1909 int
1910 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1911 {
1912     dVAR;
1913     AV * const obj = (AV*)mg->mg_obj;
1914
1915     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
1916
1917     if (obj) {
1918         av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
1919     } else {
1920         if (ckWARN(WARN_MISC))
1921             Perl_warner(aTHX_ packWARN(WARN_MISC),
1922                         "Attempt to set length of freed array");
1923     }
1924     return 0;
1925 }
1926
1927 int
1928 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
1929 {
1930     dVAR;
1931
1932     PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
1933     PERL_UNUSED_ARG(sv);
1934
1935     /* during global destruction, mg_obj may already have been freed */
1936     if (PL_in_clean_all)
1937         return 0;
1938
1939     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
1940
1941     if (mg) {
1942         /* arylen scalar holds a pointer back to the array, but doesn't own a
1943            reference. Hence the we (the array) are about to go away with it
1944            still pointing at us. Clear its pointer, else it would be pointing
1945            at free memory. See the comment in sv_magic about reference loops,
1946            and why it can't own a reference to us.  */
1947         mg->mg_obj = 0;
1948     }
1949     return 0;
1950 }
1951
1952 int
1953 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1954 {
1955     dVAR;
1956     SV* const lsv = LvTARG(sv);
1957
1958     PERL_ARGS_ASSERT_MAGIC_GETPOS;
1959     PERL_UNUSED_ARG(mg);
1960
1961     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1962         MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
1963         if (found && found->mg_len >= 0) {
1964             I32 i = found->mg_len;
1965             if (DO_UTF8(lsv))
1966                 sv_pos_b2u(lsv, &i);
1967             sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
1968             return 0;
1969         }
1970     }
1971     SvOK_off(sv);
1972     return 0;
1973 }
1974
1975 int
1976 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1977 {
1978     dVAR;
1979     SV* const lsv = LvTARG(sv);
1980     SSize_t pos;
1981     STRLEN len;
1982     STRLEN ulen = 0;
1983     MAGIC* found;
1984
1985     PERL_ARGS_ASSERT_MAGIC_SETPOS;
1986     PERL_UNUSED_ARG(mg);
1987
1988     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1989         found = mg_find(lsv, PERL_MAGIC_regex_global);
1990     else
1991         found = NULL;
1992     if (!found) {
1993         if (!SvOK(sv))
1994             return 0;
1995 #ifdef PERL_OLD_COPY_ON_WRITE
1996     if (SvIsCOW(lsv))
1997         sv_force_normal_flags(lsv, 0);
1998 #endif
1999         found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
2000                             NULL, 0);
2001     }
2002     else if (!SvOK(sv)) {
2003         found->mg_len = -1;
2004         return 0;
2005     }
2006     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
2007
2008     pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
2009
2010     if (DO_UTF8(lsv)) {
2011         ulen = sv_len_utf8(lsv);
2012         if (ulen)
2013             len = ulen;
2014     }
2015
2016     if (pos < 0) {
2017         pos += len;
2018         if (pos < 0)
2019             pos = 0;
2020     }
2021     else if (pos > (SSize_t)len)
2022         pos = len;
2023
2024     if (ulen) {
2025         I32 p = pos;
2026         sv_pos_u2b(lsv, &p, 0);
2027         pos = p;
2028     }
2029
2030     found->mg_len = pos;
2031     found->mg_flags &= ~MGf_MINMATCH;
2032
2033     return 0;
2034 }
2035
2036 int
2037 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
2038 {
2039     STRLEN len;
2040     SV * const lsv = LvTARG(sv);
2041     const char * const tmps = SvPV_const(lsv,len);
2042     I32 offs = LvTARGOFF(sv);
2043     I32 rem = LvTARGLEN(sv);
2044
2045     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
2046     PERL_UNUSED_ARG(mg);
2047
2048     if (SvUTF8(lsv))
2049         sv_pos_u2b(lsv, &offs, &rem);
2050     if (offs > (I32)len)
2051         offs = len;
2052     if (rem + offs > (I32)len)
2053         rem = len - offs;
2054     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
2055     if (SvUTF8(lsv))
2056         SvUTF8_on(sv);
2057     return 0;
2058 }
2059
2060 int
2061 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
2062 {
2063     dVAR;
2064     STRLEN len;
2065     const char * const tmps = SvPV_const(sv, len);
2066     SV * const lsv = LvTARG(sv);
2067     I32 lvoff = LvTARGOFF(sv);
2068     I32 lvlen = LvTARGLEN(sv);
2069
2070     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
2071     PERL_UNUSED_ARG(mg);
2072
2073     if (DO_UTF8(sv)) {
2074         sv_utf8_upgrade(lsv);
2075         sv_pos_u2b(lsv, &lvoff, &lvlen);
2076         sv_insert(lsv, lvoff, lvlen, tmps, len);
2077         LvTARGLEN(sv) = sv_len_utf8(sv);
2078         SvUTF8_on(lsv);
2079     }
2080     else if (lsv && SvUTF8(lsv)) {
2081         const char *utf8;
2082         sv_pos_u2b(lsv, &lvoff, &lvlen);
2083         LvTARGLEN(sv) = len;
2084         utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
2085         sv_insert(lsv, lvoff, lvlen, utf8, len);
2086         Safefree(utf8);
2087     }
2088     else {
2089         sv_insert(lsv, lvoff, lvlen, tmps, len);
2090         LvTARGLEN(sv) = len;
2091     }
2092
2093
2094     return 0;
2095 }
2096
2097 int
2098 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
2099 {
2100     dVAR;
2101
2102     PERL_ARGS_ASSERT_MAGIC_GETTAINT;
2103     PERL_UNUSED_ARG(sv);
2104
2105     TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
2106     return 0;
2107 }
2108
2109 int
2110 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
2111 {
2112     dVAR;
2113
2114     PERL_ARGS_ASSERT_MAGIC_SETTAINT;
2115     PERL_UNUSED_ARG(sv);
2116
2117     /* update taint status */
2118     if (PL_tainted)
2119         mg->mg_len |= 1;
2120     else
2121         mg->mg_len &= ~1;
2122     return 0;
2123 }
2124
2125 int
2126 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
2127 {
2128     SV * const lsv = LvTARG(sv);
2129
2130     PERL_ARGS_ASSERT_MAGIC_GETVEC;
2131     PERL_UNUSED_ARG(mg);
2132
2133     if (lsv)
2134         sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
2135     else
2136         SvOK_off(sv);
2137
2138     return 0;
2139 }
2140
2141 int
2142 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
2143 {
2144     PERL_ARGS_ASSERT_MAGIC_SETVEC;
2145     PERL_UNUSED_ARG(mg);
2146     do_vecset(sv);      /* XXX slurp this routine */
2147     return 0;
2148 }
2149
2150 int
2151 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
2152 {
2153     dVAR;
2154     SV *targ = NULL;
2155
2156     PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
2157
2158     if (LvTARGLEN(sv)) {
2159         if (mg->mg_obj) {
2160             SV * const ahv = LvTARG(sv);
2161             HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
2162             if (he)
2163                 targ = HeVAL(he);
2164         }
2165         else {
2166             AV* const av = (AV*)LvTARG(sv);
2167             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
2168                 targ = AvARRAY(av)[LvTARGOFF(sv)];
2169         }
2170         if (targ && (targ != &PL_sv_undef)) {
2171             /* somebody else defined it for us */
2172             SvREFCNT_dec(LvTARG(sv));
2173             LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
2174             LvTARGLEN(sv) = 0;
2175             SvREFCNT_dec(mg->mg_obj);
2176             mg->mg_obj = NULL;
2177             mg->mg_flags &= ~MGf_REFCOUNTED;
2178         }
2179     }
2180     else
2181         targ = LvTARG(sv);
2182     sv_setsv(sv, targ ? targ : &PL_sv_undef);
2183     return 0;
2184 }
2185
2186 int
2187 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
2188 {
2189     PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
2190     PERL_UNUSED_ARG(mg);
2191     if (LvTARGLEN(sv))
2192         vivify_defelem(sv);
2193     if (LvTARG(sv)) {
2194         sv_setsv(LvTARG(sv), sv);
2195         SvSETMAGIC(LvTARG(sv));
2196     }
2197     return 0;
2198 }
2199
2200 void
2201 Perl_vivify_defelem(pTHX_ SV *sv)
2202 {
2203     dVAR;
2204     MAGIC *mg;
2205     SV *value = NULL;
2206
2207     PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
2208
2209     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
2210         return;
2211     if (mg->mg_obj) {
2212         SV * const ahv = LvTARG(sv);
2213         HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
2214         if (he)
2215             value = HeVAL(he);
2216         if (!value || value == &PL_sv_undef)
2217             Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
2218     }
2219     else {
2220         AV* const av = (AV*)LvTARG(sv);
2221         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
2222             LvTARG(sv) = NULL;  /* array can't be extended */
2223         else {
2224             SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
2225             if (!svp || (value = *svp) == &PL_sv_undef)
2226                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
2227         }
2228     }
2229     SvREFCNT_inc_simple_void(value);
2230     SvREFCNT_dec(LvTARG(sv));
2231     LvTARG(sv) = value;
2232     LvTARGLEN(sv) = 0;
2233     SvREFCNT_dec(mg->mg_obj);
2234     mg->mg_obj = NULL;
2235     mg->mg_flags &= ~MGf_REFCOUNTED;
2236 }
2237
2238 int
2239 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
2240 {
2241     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
2242     return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
2243 }
2244
2245 int
2246 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
2247 {
2248     PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
2249     PERL_UNUSED_CONTEXT;
2250     mg->mg_len = -1;
2251     SvSCREAM_off(sv);
2252     return 0;
2253 }
2254
2255 int
2256 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
2257 {
2258     const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
2259
2260     PERL_ARGS_ASSERT_MAGIC_SETUVAR;
2261
2262     if (uf && uf->uf_set)
2263         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
2264     return 0;
2265 }
2266
2267 int
2268 Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
2269 {
2270     const char type = mg->mg_type;
2271
2272     PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
2273
2274     if (type == PERL_MAGIC_qr) {
2275     } else if (type == PERL_MAGIC_bm) {
2276         SvTAIL_off(sv);
2277         SvVALID_off(sv);
2278     } else {
2279         assert(type == PERL_MAGIC_fm);
2280         SvCOMPILED_off(sv);
2281     }
2282     return sv_unmagic(sv, type);
2283 }
2284
2285 #ifdef USE_LOCALE_COLLATE
2286 int
2287 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
2288 {
2289     PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
2290
2291     /*
2292      * RenE<eacute> Descartes said "I think not."
2293      * and vanished with a faint plop.
2294      */
2295     PERL_UNUSED_CONTEXT;
2296     PERL_UNUSED_ARG(sv);
2297     if (mg->mg_ptr) {
2298         Safefree(mg->mg_ptr);
2299         mg->mg_ptr = NULL;
2300         mg->mg_len = -1;
2301     }
2302     return 0;
2303 }
2304 #endif /* USE_LOCALE_COLLATE */
2305
2306 /* Just clear the UTF-8 cache data. */
2307 int
2308 Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
2309 {
2310     PERL_ARGS_ASSERT_MAGIC_SETUTF8;
2311     PERL_UNUSED_CONTEXT;
2312     PERL_UNUSED_ARG(sv);
2313     Safefree(mg->mg_ptr);       /* The mg_ptr holds the pos cache. */
2314     mg->mg_ptr = NULL;
2315     mg->mg_len = -1;            /* The mg_len holds the len cache. */
2316     return 0;
2317 }
2318
2319 int
2320 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
2321 {
2322     dVAR;
2323     register const char *s;
2324     register I32 paren;
2325     register const REGEXP * rx;
2326     const char * const remaining = mg->mg_ptr + 1;
2327     I32 i;
2328     STRLEN len;
2329
2330     PERL_ARGS_ASSERT_MAGIC_SET;
2331
2332     switch (*mg->mg_ptr) {
2333     case '\015': /* $^MATCH */
2334       if (strEQ(remaining, "ATCH"))
2335           goto do_match;
2336     case '`': /* ${^PREMATCH} caught below */
2337       do_prematch:
2338       paren = RX_BUFF_IDX_PREMATCH;
2339       goto setparen;
2340     case '\'': /* ${^POSTMATCH} caught below */
2341       do_postmatch:
2342       paren = RX_BUFF_IDX_POSTMATCH;
2343       goto setparen;
2344     case '&':
2345       do_match:
2346       paren = RX_BUFF_IDX_FULLMATCH;
2347       goto setparen;
2348     case '1': case '2': case '3': case '4':
2349     case '5': case '6': case '7': case '8': case '9':
2350       paren = atoi(mg->mg_ptr);
2351       setparen:
2352         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
2353             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
2354             break;
2355         } else {
2356             /* Croak with a READONLY error when a numbered match var is
2357              * set without a previous pattern match. Unless it's C<local $1>
2358              */
2359             if (!PL_localizing) {
2360                 Perl_croak(aTHX_ PL_no_modify);
2361             }
2362         }
2363     case '\001':        /* ^A */
2364         sv_setsv(PL_bodytarget, sv);
2365         break;
2366     case '\003':        /* ^C */
2367         PL_minus_c = (bool)SvIV(sv);
2368         break;
2369
2370     case '\004':        /* ^D */
2371 #ifdef DEBUGGING
2372         s = SvPV_nolen_const(sv);
2373         PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
2374         DEBUG_x(dump_all());
2375 #else
2376         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2377 #endif
2378         break;
2379     case '\005':  /* ^E */
2380         if (*(mg->mg_ptr+1) == '\0') {
2381 #ifdef MACOS_TRADITIONAL
2382             gMacPerl_OSErr = SvIV(sv);
2383 #else
2384 #  ifdef VMS
2385             set_vaxc_errno(SvIV(sv));
2386 #  else
2387 #    ifdef WIN32
2388             SetLastError( SvIV(sv) );
2389 #    else
2390 #      ifdef OS2
2391             os2_setsyserrno(SvIV(sv));
2392 #      else
2393             /* will anyone ever use this? */
2394             SETERRNO(SvIV(sv), 4);
2395 #      endif
2396 #    endif
2397 #  endif
2398 #endif
2399         }
2400         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2401             if (PL_encoding)
2402                 SvREFCNT_dec(PL_encoding);
2403             if (SvOK(sv) || SvGMAGICAL(sv)) {
2404                 PL_encoding = newSVsv(sv);
2405             }
2406             else {
2407                 PL_encoding = NULL;
2408             }
2409         }
2410         break;
2411     case '\006':        /* ^F */
2412         PL_maxsysfd = SvIV(sv);
2413         break;
2414     case '\010':        /* ^H */
2415         PL_hints = SvIV(sv);
2416         break;
2417     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2418         Safefree(PL_inplace);
2419         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2420         break;
2421     case '\017':        /* ^O */
2422         if (*(mg->mg_ptr+1) == '\0') {
2423             Safefree(PL_osname);
2424             PL_osname = NULL;
2425             if (SvOK(sv)) {
2426                 TAINT_PROPER("assigning to $^O");
2427                 PL_osname = savesvpv(sv);
2428             }
2429         }
2430         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2431             STRLEN len;
2432             const char *const start = SvPV(sv, len);
2433             const char *out = (const char*)memchr(start, '\0', len);
2434             SV *tmp;
2435             struct refcounted_he *tmp_he;
2436
2437
2438             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2439             PL_hints
2440                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2441
2442             /* Opening for input is more common than opening for output, so
2443                ensure that hints for input are sooner on linked list.  */
2444             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2445                                        SVs_TEMP | SvUTF8(sv))
2446                 : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv));
2447
2448             tmp_he
2449                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2450                                          newSVpvs_flags("open>", SVs_TEMP),
2451                                          tmp);
2452
2453             /* The UTF-8 setting is carried over  */
2454             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2455
2456             PL_compiling.cop_hints_hash
2457                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2458                                          newSVpvs_flags("open<", SVs_TEMP),
2459                                          tmp);
2460         }
2461         break;
2462     case '\020':        /* ^P */
2463       if (*remaining == '\0') { /* ^P */
2464           PL_perldb = SvIV(sv);
2465           if (PL_perldb && !PL_DBsingle)
2466               init_debugger();
2467           break;
2468       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2469           goto do_prematch;
2470       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2471           goto do_postmatch;
2472       }
2473     case '\024':        /* ^T */
2474 #ifdef BIG_TIME
2475         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2476 #else
2477         PL_basetime = (Time_t)SvIV(sv);
2478 #endif
2479         break;
2480     case '\025':        /* ^UTF8CACHE */
2481          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2482              PL_utf8cache = (signed char) sv_2iv(sv);
2483          }
2484          break;
2485     case '\027':        /* ^W & $^WARNING_BITS */
2486         if (*(mg->mg_ptr+1) == '\0') {
2487             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2488                 i = SvIV(sv);
2489                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2490                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2491             }
2492         }
2493         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2494             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2495                 if (!SvPOK(sv) && PL_localizing) {
2496                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2497                     PL_compiling.cop_warnings = pWARN_NONE;
2498                     break;
2499                 }
2500                 {
2501                     STRLEN len, i;
2502                     int accumulate = 0 ;
2503                     int any_fatals = 0 ;
2504                     const char * const ptr = SvPV_const(sv, len) ;
2505                     for (i = 0 ; i < len ; ++i) {
2506                         accumulate |= ptr[i] ;
2507                         any_fatals |= (ptr[i] & 0xAA) ;
2508                     }
2509                     if (!accumulate) {
2510                         if (!specialWARN(PL_compiling.cop_warnings))
2511                             PerlMemShared_free(PL_compiling.cop_warnings);
2512                         PL_compiling.cop_warnings = pWARN_NONE;
2513                     }
2514                     /* Yuck. I can't see how to abstract this:  */
2515                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2516                                        WARN_ALL) && !any_fatals) {
2517                         if (!specialWARN(PL_compiling.cop_warnings))
2518                             PerlMemShared_free(PL_compiling.cop_warnings);
2519                         PL_compiling.cop_warnings = pWARN_ALL;
2520                         PL_dowarn |= G_WARN_ONCE ;
2521                     }
2522                     else {
2523                         STRLEN len;
2524                         const char *const p = SvPV_const(sv, len);
2525
2526                         PL_compiling.cop_warnings
2527                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2528                                                          p, len);
2529
2530                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2531                             PL_dowarn |= G_WARN_ONCE ;
2532                     }
2533
2534                 }
2535             }
2536         }
2537         break;
2538     case '.':
2539         if (PL_localizing) {
2540             if (PL_localizing == 1)
2541                 SAVESPTR(PL_last_in_gv);
2542         }
2543         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2544             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2545         break;
2546     case '^':
2547         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2548         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2549         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2550         break;
2551     case '~':
2552         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2553         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2554         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2555         break;
2556     case '=':
2557         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2558         break;
2559     case '-':
2560         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2561         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2562             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2563         break;
2564     case '%':
2565         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2566         break;
2567     case '|':
2568         {
2569             IO * const io = GvIOp(PL_defoutgv);
2570             if(!io)
2571               break;
2572             if ((SvIV(sv)) == 0)
2573                 IoFLAGS(io) &= ~IOf_FLUSH;
2574             else {
2575                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2576                     PerlIO *ofp = IoOFP(io);
2577                     if (ofp)
2578                         (void)PerlIO_flush(ofp);
2579                     IoFLAGS(io) |= IOf_FLUSH;
2580                 }
2581             }
2582         }
2583         break;
2584     case '/':
2585         SvREFCNT_dec(PL_rs);
2586         PL_rs = newSVsv(sv);
2587         break;
2588     case '\\':
2589         if (PL_ors_sv)
2590             SvREFCNT_dec(PL_ors_sv);
2591         if (SvOK(sv) || SvGMAGICAL(sv)) {
2592             PL_ors_sv = newSVsv(sv);
2593         }
2594         else {
2595             PL_ors_sv = NULL;
2596         }
2597         break;
2598     case ',':
2599         if (PL_ofs_sv)
2600             SvREFCNT_dec(PL_ofs_sv);
2601         if (SvOK(sv) || SvGMAGICAL(sv)) {
2602             PL_ofs_sv = newSVsv(sv);
2603         }
2604         else {
2605             PL_ofs_sv = NULL;
2606         }
2607         break;
2608     case '[':
2609         CopARYBASE_set(&PL_compiling, SvIV(sv));
2610         break;
2611     case '?':
2612 #ifdef COMPLEX_STATUS
2613         if (PL_localizing == 2) {
2614             PL_statusvalue = LvTARGOFF(sv);
2615             PL_statusvalue_vms = LvTARGLEN(sv);
2616         }
2617         else
2618 #endif
2619 #ifdef VMSISH_STATUS
2620         if (VMSISH_STATUS)
2621             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2622         else
2623 #endif
2624             STATUS_UNIX_EXIT_SET(SvIV(sv));
2625         break;
2626     case '!':
2627         {
2628 #ifdef VMS
2629 #   define PERL_VMS_BANG vaxc$errno
2630 #else
2631 #   define PERL_VMS_BANG 0
2632 #endif
2633         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2634                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2635         }
2636         break;
2637     case '<':
2638         PL_uid = SvIV(sv);
2639         if (PL_delaymagic) {
2640             PL_delaymagic |= DM_RUID;
2641             break;                              /* don't do magic till later */
2642         }
2643 #ifdef HAS_SETRUID
2644         (void)setruid((Uid_t)PL_uid);
2645 #else
2646 #ifdef HAS_SETREUID
2647         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2648 #else
2649 #ifdef HAS_SETRESUID
2650       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2651 #else
2652         if (PL_uid == PL_euid) {                /* special case $< = $> */
2653 #ifdef PERL_DARWIN
2654             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2655             if (PL_uid != 0 && PerlProc_getuid() == 0)
2656                 (void)PerlProc_setuid(0);
2657 #endif
2658             (void)PerlProc_setuid(PL_uid);
2659         } else {
2660             PL_uid = PerlProc_getuid();
2661             Perl_croak(aTHX_ "setruid() not implemented");
2662         }
2663 #endif
2664 #endif
2665 #endif
2666         PL_uid = PerlProc_getuid();
2667         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2668         break;
2669     case '>':
2670         PL_euid = SvIV(sv);
2671         if (PL_delaymagic) {
2672             PL_delaymagic |= DM_EUID;
2673             break;                              /* don't do magic till later */
2674         }
2675 #ifdef HAS_SETEUID
2676         (void)seteuid((Uid_t)PL_euid);
2677 #else
2678 #ifdef HAS_SETREUID
2679         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2680 #else
2681 #ifdef HAS_SETRESUID
2682         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2683 #else
2684         if (PL_euid == PL_uid)          /* special case $> = $< */
2685             PerlProc_setuid(PL_euid);
2686         else {
2687             PL_euid = PerlProc_geteuid();
2688             Perl_croak(aTHX_ "seteuid() not implemented");
2689         }
2690 #endif
2691 #endif
2692 #endif
2693         PL_euid = PerlProc_geteuid();
2694         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2695         break;
2696     case '(':
2697         PL_gid = SvIV(sv);
2698         if (PL_delaymagic) {
2699             PL_delaymagic |= DM_RGID;
2700             break;                              /* don't do magic till later */
2701         }
2702 #ifdef HAS_SETRGID
2703         (void)setrgid((Gid_t)PL_gid);
2704 #else
2705 #ifdef HAS_SETREGID
2706         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2707 #else
2708 #ifdef HAS_SETRESGID
2709       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2710 #else
2711         if (PL_gid == PL_egid)                  /* special case $( = $) */
2712             (void)PerlProc_setgid(PL_gid);
2713         else {
2714             PL_gid = PerlProc_getgid();
2715             Perl_croak(aTHX_ "setrgid() not implemented");
2716         }
2717 #endif
2718 #endif
2719 #endif
2720         PL_gid = PerlProc_getgid();
2721         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2722         break;
2723     case ')':
2724 #ifdef HAS_SETGROUPS
2725         {
2726             const char *p = SvPV_const(sv, len);
2727             Groups_t *gary = NULL;
2728
2729             while (isSPACE(*p))
2730                 ++p;
2731             PL_egid = Atol(p);
2732             for (i = 0; i < NGROUPS; ++i) {
2733                 while (*p && !isSPACE(*p))
2734                     ++p;
2735                 while (isSPACE(*p))
2736                     ++p;
2737                 if (!*p)
2738                     break;
2739                 if(!gary)
2740                     Newx(gary, i + 1, Groups_t);
2741                 else
2742                     Renew(gary, i + 1, Groups_t);
2743                 gary[i] = Atol(p);
2744             }
2745             if (i)
2746                 (void)setgroups(i, gary);
2747             Safefree(gary);
2748         }
2749 #else  /* HAS_SETGROUPS */
2750         PL_egid = SvIV(sv);
2751 #endif /* HAS_SETGROUPS */
2752         if (PL_delaymagic) {
2753             PL_delaymagic |= DM_EGID;
2754             break;                              /* don't do magic till later */
2755         }
2756 #ifdef HAS_SETEGID
2757         (void)setegid((Gid_t)PL_egid);
2758 #else
2759 #ifdef HAS_SETREGID
2760         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2761 #else
2762 #ifdef HAS_SETRESGID
2763         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2764 #else
2765         if (PL_egid == PL_gid)                  /* special case $) = $( */
2766             (void)PerlProc_setgid(PL_egid);
2767         else {
2768             PL_egid = PerlProc_getegid();
2769             Perl_croak(aTHX_ "setegid() not implemented");
2770         }
2771 #endif
2772 #endif
2773 #endif
2774         PL_egid = PerlProc_getegid();
2775         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2776         break;
2777     case ':':
2778         PL_chopset = SvPV_force(sv,len);
2779         break;
2780 #ifndef MACOS_TRADITIONAL
2781     case '0':
2782         LOCK_DOLLARZERO_MUTEX;
2783 #ifdef HAS_SETPROCTITLE
2784         /* The BSDs don't show the argv[] in ps(1) output, they
2785          * show a string from the process struct and provide
2786          * the setproctitle() routine to manipulate that. */
2787         if (PL_origalen != 1) {
2788             s = SvPV_const(sv, len);
2789 #   if __FreeBSD_version > 410001
2790             /* The leading "-" removes the "perl: " prefix,
2791              * but not the "(perl) suffix from the ps(1)
2792              * output, because that's what ps(1) shows if the
2793              * argv[] is modified. */
2794             setproctitle("-%s", s);
2795 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2796             /* This doesn't really work if you assume that
2797              * $0 = 'foobar'; will wipe out 'perl' from the $0
2798              * because in ps(1) output the result will be like
2799              * sprintf("perl: %s (perl)", s)
2800              * I guess this is a security feature:
2801              * one (a user process) cannot get rid of the original name.
2802              * --jhi */
2803             setproctitle("%s", s);
2804 #   endif
2805         }
2806 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2807         if (PL_origalen != 1) {
2808              union pstun un;
2809              s = SvPV_const(sv, len);
2810              un.pst_command = (char *)s;
2811              pstat(PSTAT_SETCMD, un, len, 0, 0);
2812         }
2813 #else
2814         if (PL_origalen > 1) {
2815             /* PL_origalen is set in perl_parse(). */
2816             s = SvPV_force(sv,len);
2817             if (len >= (STRLEN)PL_origalen-1) {
2818                 /* Longer than original, will be truncated. We assume that
2819                  * PL_origalen bytes are available. */
2820                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2821             }
2822             else {
2823                 /* Shorter than original, will be padded. */
2824 #ifdef PERL_DARWIN
2825                 /* Special case for Mac OS X: see [perl #38868] */
2826                 const int pad = 0;
2827 #else
2828                 /* Is the space counterintuitive?  Yes.
2829                  * (You were expecting \0?)
2830                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2831                  * --jhi */
2832                 const int pad = ' ';
2833 #endif
2834                 Copy(s, PL_origargv[0], len, char);
2835                 PL_origargv[0][len] = 0;
2836                 memset(PL_origargv[0] + len + 1,
2837                        pad,  PL_origalen - len - 1);
2838             }
2839             PL_origargv[0][PL_origalen-1] = 0;
2840             for (i = 1; i < PL_origargc; i++)
2841                 PL_origargv[i] = 0;
2842         }
2843 #endif
2844         UNLOCK_DOLLARZERO_MUTEX;
2845         break;
2846 #endif
2847     }
2848     return 0;
2849 }
2850
2851 I32
2852 Perl_whichsig(pTHX_ const char *sig)
2853 {
2854     register char* const* sigv;
2855
2856     PERL_ARGS_ASSERT_WHICHSIG;
2857     PERL_UNUSED_CONTEXT;
2858
2859     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2860         if (strEQ(sig,*sigv))
2861             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2862 #ifdef SIGCLD
2863     if (strEQ(sig,"CHLD"))
2864         return SIGCLD;
2865 #endif
2866 #ifdef SIGCHLD
2867     if (strEQ(sig,"CLD"))
2868         return SIGCHLD;
2869 #endif
2870     return -1;
2871 }
2872
2873 Signal_t
2874 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2875 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2876 #else
2877 Perl_sighandler(int sig)
2878 #endif
2879 {
2880 #ifdef PERL_GET_SIG_CONTEXT
2881     dTHXa(PERL_GET_SIG_CONTEXT);
2882 #else
2883     dTHX;
2884 #endif
2885     dSP;
2886     GV *gv = NULL;
2887     SV *sv = NULL;
2888     SV * const tSv = PL_Sv;
2889     CV *cv = NULL;
2890     OP *myop = PL_op;
2891     U32 flags = 0;
2892     XPV * const tXpv = PL_Xpv;
2893
2894     if (PL_savestack_ix + 15 <= PL_savestack_max)
2895         flags |= 1;
2896     if (PL_markstack_ptr < PL_markstack_max - 2)
2897         flags |= 4;
2898     if (PL_scopestack_ix < PL_scopestack_max - 3)
2899         flags |= 16;
2900
2901     if (!PL_psig_ptr[sig]) {
2902                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2903                                  PL_sig_name[sig]);
2904                 exit(sig);
2905         }
2906
2907     /* Max number of items pushed there is 3*n or 4. We cannot fix
2908        infinity, so we fix 4 (in fact 5): */
2909     if (flags & 1) {
2910         PL_savestack_ix += 5;           /* Protect save in progress. */
2911         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2912     }
2913     if (flags & 4)
2914         PL_markstack_ptr++;             /* Protect mark. */
2915     if (flags & 16)
2916         PL_scopestack_ix += 1;
2917     /* sv_2cv is too complicated, try a simpler variant first: */
2918     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2919         || SvTYPE(cv) != SVt_PVCV) {
2920         HV *st;
2921         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2922     }
2923
2924     if (!cv || !CvROOT(cv)) {
2925         if (ckWARN(WARN_SIGNAL))
2926             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2927                 PL_sig_name[sig], (gv ? GvENAME(gv)
2928                                 : ((cv && CvGV(cv))
2929                                    ? GvENAME(CvGV(cv))
2930                                    : "__ANON__")));
2931         goto cleanup;
2932     }
2933
2934     if(PL_psig_name[sig]) {
2935         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2936         flags |= 64;
2937 #if !defined(PERL_IMPLICIT_CONTEXT)
2938         PL_sig_sv = sv;
2939 #endif
2940     } else {
2941         sv = sv_newmortal();
2942         sv_setpv(sv,PL_sig_name[sig]);
2943     }
2944
2945     PUSHSTACKi(PERLSI_SIGNAL);
2946     PUSHMARK(SP);
2947     PUSHs(sv);
2948 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2949     {
2950          struct sigaction oact;
2951
2952          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2953               if (sip) {
2954                    HV *sih = newHV();
2955                    SV *rv  = newRV_noinc((SV*)sih);
2956                    /* The siginfo fields signo, code, errno, pid, uid,
2957                     * addr, status, and band are defined by POSIX/SUSv3. */
2958                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2959                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
2960 #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. */
2961                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
2962                    hv_stores(sih, "status",     newSViv(sip->si_status));
2963                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
2964                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
2965                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
2966                    hv_stores(sih, "band",       newSViv(sip->si_band));
2967 #endif
2968                    EXTEND(SP, 2);
2969                    PUSHs((SV*)rv);
2970                    mPUSHp((char *)sip, sizeof(*sip));
2971               }
2972
2973          }
2974     }
2975 #endif
2976     PUTBACK;
2977
2978     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2979
2980     POPSTACK;
2981     if (SvTRUE(ERRSV)) {
2982 #ifndef PERL_MICRO
2983 #ifdef HAS_SIGPROCMASK
2984         /* Handler "died", for example to get out of a restart-able read().
2985          * Before we re-do that on its behalf re-enable the signal which was
2986          * blocked by the system when we entered.
2987          */
2988         sigset_t set;
2989         sigemptyset(&set);
2990         sigaddset(&set,sig);
2991         sigprocmask(SIG_UNBLOCK, &set, NULL);
2992 #else
2993         /* Not clear if this will work */
2994         (void)rsignal(sig, SIG_IGN);
2995         (void)rsignal(sig, PL_csighandlerp);
2996 #endif
2997 #endif /* !PERL_MICRO */
2998         Perl_die(aTHX_ NULL);
2999     }
3000 cleanup:
3001     if (flags & 1)
3002         PL_savestack_ix -= 8; /* Unprotect save in progress. */
3003     if (flags & 4)
3004         PL_markstack_ptr--;
3005     if (flags & 16)
3006         PL_scopestack_ix -= 1;
3007     if (flags & 64)
3008         SvREFCNT_dec(sv);
3009     PL_op = myop;                       /* Apparently not needed... */
3010
3011     PL_Sv = tSv;                        /* Restore global temporaries. */
3012     PL_Xpv = tXpv;
3013     return;
3014 }
3015
3016
3017 static void
3018 S_restore_magic(pTHX_ const void *p)
3019 {
3020     dVAR;
3021     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
3022     SV* const sv = mgs->mgs_sv;
3023
3024     if (!sv)
3025         return;
3026
3027     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3028     {
3029 #ifdef PERL_OLD_COPY_ON_WRITE
3030         /* While magic was saved (and off) sv_setsv may well have seen
3031            this SV as a prime candidate for COW.  */
3032         if (SvIsCOW(sv))
3033             sv_force_normal_flags(sv, 0);
3034 #endif
3035
3036         if (mgs->mgs_flags)
3037             SvFLAGS(sv) |= mgs->mgs_flags;
3038         else
3039             mg_magical(sv);
3040         if (SvGMAGICAL(sv)) {
3041             /* downgrade public flags to private,
3042                and discard any other private flags */
3043
3044             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
3045             if (pubflags) {
3046                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
3047                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
3048             }
3049         }
3050     }
3051
3052     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3053
3054     /* If we're still on top of the stack, pop us off.  (That condition
3055      * will be satisfied if restore_magic was called explicitly, but *not*
3056      * if it's being called via leave_scope.)
3057      * The reason for doing this is that otherwise, things like sv_2cv()
3058      * may leave alloc gunk on the savestack, and some code
3059      * (e.g. sighandler) doesn't expect that...
3060      */
3061     if (PL_savestack_ix == mgs->mgs_ss_ix)
3062     {
3063         I32 popval = SSPOPINT;
3064         assert(popval == SAVEt_DESTRUCTOR_X);
3065         PL_savestack_ix -= 2;
3066         popval = SSPOPINT;
3067         assert(popval == SAVEt_ALLOC);
3068         popval = SSPOPINT;
3069         PL_savestack_ix -= popval;
3070     }
3071
3072 }
3073
3074 static void
3075 S_unwind_handler_stack(pTHX_ const void *p)
3076 {
3077     dVAR;
3078     const U32 flags = *(const U32*)p;
3079
3080     PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3081
3082     if (flags & 1)
3083         PL_savestack_ix -= 5; /* Unprotect save in progress. */
3084 #if !defined(PERL_IMPLICIT_CONTEXT)
3085     if (flags & 64)
3086         SvREFCNT_dec(PL_sig_sv);
3087 #endif
3088 }
3089
3090 /*
3091 =for apidoc magic_sethint
3092
3093 Triggered by a store to %^H, records the key/value pair to
3094 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3095 anything that would need a deep copy.  Maybe we should warn if we find a
3096 reference.
3097
3098 =cut
3099 */
3100 int
3101 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3102 {
3103     dVAR;
3104     SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
3105         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3106
3107     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3108
3109     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3110        an alternative leaf in there, with PL_compiling.cop_hints being used if
3111        it's NULL. If needed for threads, the alternative could lock a mutex,
3112        or take other more complex action.  */
3113
3114     /* Something changed in %^H, so it will need to be restored on scope exit.
3115        Doing this here saves a lot of doing it manually in perl code (and
3116        forgetting to do it, and consequent subtle errors.  */
3117     PL_hints |= HINT_LOCALIZE_HH;
3118     PL_compiling.cop_hints_hash
3119         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3120     return 0;
3121 }
3122
3123 /*
3124 =for apidoc magic_clearhint
3125
3126 Triggered by a delete from %^H, records the key to
3127 C<PL_compiling.cop_hints_hash>.
3128
3129 =cut
3130 */
3131 int
3132 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3133 {
3134     dVAR;
3135
3136     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3137     PERL_UNUSED_ARG(sv);
3138
3139     assert(mg->mg_len == HEf_SVKEY);
3140
3141     PERL_UNUSED_ARG(sv);
3142
3143     PL_hints |= HINT_LOCALIZE_HH;
3144     PL_compiling.cop_hints_hash
3145         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3146                                  (SV *)mg->mg_ptr, &PL_sv_placeholder);
3147     return 0;
3148 }
3149
3150 /*
3151  * Local variables:
3152  * c-indentation-style: bsd
3153  * c-basic-offset: 4
3154  * indent-tabs-mode: t
3155  * End:
3156  *
3157  * ex: set ts=8 sts=4 sw=4 noet:
3158  */