mg.c

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