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