mg.c

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