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