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