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
 387     PERL_ARGS_ASSERT_MG_CLEAR;
 388
 389     save_magic(mgs_ix, sv);
 390
 391     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 392         const MGVTBL* const vtbl = mg->mg_virtual;
 393         /* omit GSKIP -- never set here */
 394
 395         if (vtbl && vtbl->svt_clear)
 396             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 397     }
 398
 399     restore_magic(INT2PTR(void*, (IV)mgs_ix));
 400     return 0;
 401 }
 402
 403 /*
 404 =for apidoc mg_find
 405
 406 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 407
 408 =cut
 409 */
 410
 411 MAGIC*
 412 Perl_mg_find(pTHX_ const SV *sv, int type)
 413 {
 414     PERL_UNUSED_CONTEXT;
 415     if (sv) {
 416         MAGIC *mg;
 417         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 418             if (mg->mg_type == type)
 419                 return mg;
 420         }
 421     }
 422     return NULL;
 423 }
 424
 425 /*
 426 =for apidoc mg_copy
 427
 428 Copies the magic from one SV to another.  See C<sv_magic>.
 429
 430 =cut
 431 */
 432
 433 int
 434 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 435 {
 436     int count = 0;
 437     MAGIC* mg;
 438
 439     PERL_ARGS_ASSERT_MG_COPY;
 440
 441     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 442         const MGVTBL* const vtbl = mg->mg_virtual;
 443         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 444             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 445         }
 446         else {
 447             const char type = mg->mg_type;
 448             if (isUPPER(type) && type != PERL_MAGIC_uvar) {
 449                 sv_magic(nsv,
 450                      (type == PERL_MAGIC_tied)
 451                         ? SvTIED_obj(sv, mg)
 452                         : (type == PERL_MAGIC_regdata && mg->mg_obj)
 453                             ? sv
 454                             : mg->mg_obj,
 455                      toLOWER(type), key, klen);
 456                 count++;
 457             }
 458         }
 459     }
 460     return count;
 461 }
 462
 463 /*
 464 =for apidoc mg_localize
 465
 466 Copy some of the magic from an existing SV to new localized version of that
 467 SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
 468 taint, pos).
 469
 470 If setmagic is false then no set magic will be called on the new (empty) SV.
 471 This typically means that assignment will soon follow (e.g. 'local $x = $y'),
 472 and that will handle the magic.
 473
 474 =cut
 475 */
 476
 477 void
 478 Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
 479 {
 480     dVAR;
 481     MAGIC *mg;
 482
 483     PERL_ARGS_ASSERT_MG_LOCALIZE;
 484
 485     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 486         const MGVTBL* const vtbl = mg->mg_virtual;
 487         if (!S_is_container_magic(mg))
 488             continue;
 489
 490         if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
 491             (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
 492         else
 493             sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
 494                             mg->mg_ptr, mg->mg_len);
 495
 496         /* container types should remain read-only across localization */
 497         SvFLAGS(nsv) |= SvREADONLY(sv);
 498     }
 499
 500     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 501         SvFLAGS(nsv) |= SvMAGICAL(sv);
 502         if (setmagic) {
 503             PL_localizing = 1;
 504             SvSETMAGIC(nsv);
 505             PL_localizing = 0;
 506         }
 507     }
 508 }
 509
 510 /*
 511 =for apidoc mg_free
 512
 513 Free any magic storage used by the SV.  See C<sv_magic>.
 514
 515 =cut
 516 */
 517
 518 int
 519 Perl_mg_free(pTHX_ SV *sv)
 520 {
 521     MAGIC* mg;
 522     MAGIC* moremagic;
 523
 524     PERL_ARGS_ASSERT_MG_FREE;
 525
 526     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 527         const MGVTBL* const vtbl = mg->mg_virtual;
 528         moremagic = mg->mg_moremagic;
 529         if (vtbl && vtbl->svt_free)
 530             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 531         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 532             if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 533                 Safefree(mg->mg_ptr);
 534             else if (mg->mg_len == HEf_SVKEY)
 535                 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
 536         }
 537         if (mg->mg_flags & MGf_REFCOUNTED)
 538             SvREFCNT_dec(mg->mg_obj);
 539         Safefree(mg);
 540         SvMAGIC_set(sv, moremagic);
 541     }
 542     SvMAGIC_set(sv, NULL);
 543     SvMAGICAL_off(sv);
 544     return 0;
 545 }
 546
 547 #include <signal.h>
 548
 549 U32
 550 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 551 {
 552     dVAR;
 553     PERL_UNUSED_ARG(sv);
 554
 555     PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
 556
 557     if (PL_curpm) {
 558         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 559         if (rx) {
 560             if (mg->mg_obj) {                   /* @+ */
 561                 /* return the number possible */
 562                 return RX_NPARENS(rx);
 563             } else {                            /* @- */
 564                 I32 paren = RX_LASTPAREN(rx);
 565
 566                 /* return the last filled */
 567                 while ( paren >= 0
 568                         && (RX_OFFS(rx)[paren].start == -1
 569                             || RX_OFFS(rx)[paren].end == -1) )
 570                     paren--;
 571                 return (U32)paren;
 572             }
 573         }
 574     }
 575
 576     return (U32)-1;
 577 }
 578
 579 int
 580 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 581 {
 582     dVAR;
 583
 584     PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
 585
 586     if (PL_curpm) {
 587         register const REGEXP * const rx = PM_GETRE(PL_curpm);
 588         if (rx) {
 589             register const I32 paren = mg->mg_len;
 590             register I32 s;
 591             register I32 t;
 592             if (paren < 0)
 593                 return 0;
 594             if (paren <= (I32)RX_NPARENS(rx) &&
 595                 (s = RX_OFFS(rx)[paren].start) != -1 &&
 596                 (t = RX_OFFS(rx)[paren].end) != -1)
 597                 {
 598                     register I32 i;
 599                     if (mg->mg_obj)             /* @+ */
 600                         i = t;
 601                     else                        /* @- */
 602                         i = s;
 603
 604                     if (i > 0 && RX_MATCH_UTF8(rx)) {
 605                         const char * const b = RX_SUBBEG(rx);
 606                         if (b)
 607                             i = utf8_length((U8*)b, (U8*)(b+i));
 608                     }
 609
 610                     sv_setiv(sv, i);
 611                 }
 612         }
 613     }
 614     return 0;
 615 }
 616
 617 int
 618 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 619 {
 620     PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
 621     PERL_UNUSED_ARG(sv);
 622     PERL_UNUSED_ARG(mg);
 623     Perl_croak(aTHX_ "%s", PL_no_modify);
 624     NORETURN_FUNCTION_END;
 625 }
 626
 627 U32
 628 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 629 {
 630     dVAR;
 631     register I32 paren;
 632     register I32 i;
 633     register const REGEXP * rx;
 634     const char * const remaining = mg->mg_ptr + 1;
 635
 636     PERL_ARGS_ASSERT_MAGIC_LEN;
 637
 638     switch (*mg->mg_ptr) {
 639     case '\020':
 640       if (*remaining == '\0') { /* ^P */
 641           break;
 642       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
 643           goto do_prematch;
 644       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
 645           goto do_postmatch;
 646       }
 647       break;
 648     case '\015': /* $^MATCH */
 649         if (strEQ(remaining, "ATCH")) {
 650         goto do_match;
 651     } else {
 652         break;
 653     }
 654     case '`':
 655       do_prematch:
 656       paren = RX_BUFF_IDX_PREMATCH;
 657       goto maybegetparen;
 658     case '\'':
 659       do_postmatch:
 660       paren = RX_BUFF_IDX_POSTMATCH;
 661       goto maybegetparen;
 662     case '&':
 663       do_match:
 664       paren = RX_BUFF_IDX_FULLMATCH;
 665       goto maybegetparen;
 666     case '1': case '2': case '3': case '4':
 667     case '5': case '6': case '7': case '8': case '9':
 668       paren = atoi(mg->mg_ptr);
 669     maybegetparen:
 670         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 671       getparen:
 672         i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
 673
 674                 if (i < 0)
 675                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 676                 return i;
 677         } else {
 678                 if (ckWARN(WARN_UNINITIALIZED))
 679                     report_uninit(sv);
 680                 return 0;
 681         }
 682     case '+':
 683         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 684             paren = RX_LASTPAREN(rx);
 685             if (paren)
 686                 goto getparen;
 687         }
 688         return 0;
 689     case '\016': /* ^N */
 690         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 691             paren = RX_LASTCLOSEPAREN(rx);
 692             if (paren)
 693                 goto getparen;
 694         }
 695         return 0;
 696     }
 697     magic_get(sv,mg);
 698     if (!SvPOK(sv) && SvNIOK(sv)) {
 699         sv_2pv(sv, 0);
 700     }
 701     if (SvPOK(sv))
 702         return SvCUR(sv);
 703     return 0;
 704 }
 705
 706 #define SvRTRIM(sv) STMT_START { \
 707     if (SvPOK(sv)) { \
 708         STRLEN len = SvCUR(sv); \
 709         char * const p = SvPVX(sv); \
 710         while (len > 0 && isSPACE(p[len-1])) \
 711            --len; \
 712         SvCUR_set(sv, len); \
 713         p[len] = '\0'; \
 714     } \
 715 } STMT_END
 716
 717 void
 718 Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
 719 {
 720     PERL_ARGS_ASSERT_EMULATE_COP_IO;
 721
 722     if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
 723         sv_setsv(sv, &PL_sv_undef);
 724     else {
 725         sv_setpvs(sv, "");
 726         SvUTF8_off(sv);
 727         if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
 728             SV *const value = Perl_refcounted_he_fetch(aTHX_
 729                                                        c->cop_hints_hash,
 730                                                        0, "open<", 5, 0, 0);
 731             assert(value);
 732             sv_catsv(sv, value);
 733         }
 734         sv_catpvs(sv, "\0");
 735         if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
 736             SV *const value = Perl_refcounted_he_fetch(aTHX_
 737                                                        c->cop_hints_hash,
 738                                                        0, "open>", 5, 0, 0);
 739             assert(value);
 740             sv_catsv(sv, value);
 741         }
 742     }
 743 }
 744
 745 int
 746 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 747 {
 748     dVAR;
 749     register I32 paren;
 750     register char *s = NULL;
 751     register REGEXP *rx;
 752     const char * const remaining = mg->mg_ptr + 1;
 753     const char nextchar = *remaining;
 754
 755     PERL_ARGS_ASSERT_MAGIC_GET;
 756
 757     switch (*mg->mg_ptr) {
 758     case '\001':                /* ^A */
 759         sv_setsv(sv, PL_bodytarget);
 760         break;
 761     case '\003':                /* ^C, ^CHILD_ERROR_NATIVE */
 762         if (nextchar == '\0') {
 763             sv_setiv(sv, (IV)PL_minus_c);
 764         }
 765         else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
 766             sv_setiv(sv, (IV)STATUS_NATIVE);
 767         }
 768         break;
 769
 770     case '\004':                /* ^D */
 771         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 772         break;
 773     case '\005':  /* ^E */
 774          if (nextchar == '\0') {
 775 #if defined(VMS)
 776              {
 777 #                 include <descrip.h>
 778 #                 include <starlet.h>
 779                   char msg[255];
 780                   $DESCRIPTOR(msgdsc,msg);
 781                   sv_setnv(sv,(NV) vaxc$errno);
 782                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 783                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 784                   else
 785                        sv_setpvs(sv,"");
 786              }
 787 #elif defined(OS2)
 788              if (!(_emx_env & 0x200)) { /* Under DOS */
 789                   sv_setnv(sv, (NV)errno);
 790                   sv_setpv(sv, errno ? Strerror(errno) : "");
 791              } else {
 792                   if (errno != errno_isOS2) {
 793                        const int tmp = _syserrno();
 794                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 795                             Perl_rc = tmp;
 796                   }
 797                   sv_setnv(sv, (NV)Perl_rc);
 798                   sv_setpv(sv, os2error(Perl_rc));
 799              }
 800 #elif defined(WIN32)
 801              {
 802                   const DWORD dwErr = GetLastError();
 803                   sv_setnv(sv, (NV)dwErr);
 804                   if (dwErr) {
 805                        PerlProc_GetOSError(sv, dwErr);
 806                   }
 807                   else
 808                        sv_setpvs(sv, "");
 809                   SetLastError(dwErr);
 810              }
 811 #else
 812              {
 813                  dSAVE_ERRNO;
 814                  sv_setnv(sv, (NV)errno);
 815                  sv_setpv(sv, errno ? Strerror(errno) : "");
 816                  RESTORE_ERRNO;
 817              }
 818 #endif
 819              SvRTRIM(sv);
 820              SvNOK_on(sv);      /* what a wonderful hack! */
 821          }
 822          else if (strEQ(remaining, "NCODING"))
 823               sv_setsv(sv, PL_encoding);
 824          break;
 825     case '\006':                /* ^F */
 826         sv_setiv(sv, (IV)PL_maxsysfd);
 827         break;
 828     case '\010':                /* ^H */
 829         sv_setiv(sv, (IV)PL_hints);
 830         break;
 831     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 832         sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
 833         break;
 834     case '\017':                /* ^O & ^OPEN */
 835         if (nextchar == '\0') {
 836             sv_setpv(sv, PL_osname);
 837             SvTAINTED_off(sv);
 838         }
 839         else if (strEQ(remaining, "PEN")) {
 840             Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
 841         }
 842         break;
 843     case '\020':
 844         if (nextchar == '\0') {       /* ^P */
 845             sv_setiv(sv, (IV)PL_perldb);
 846         } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
 847             goto do_prematch_fetch;
 848         } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
 849             goto do_postmatch_fetch;
 850         }
 851         break;
 852     case '\023':                /* ^S */
 853         if (nextchar == '\0') {
 854             if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
 855                 SvOK_off(sv);
 856             else if (PL_in_eval)
 857                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 858             else
 859                 sv_setiv(sv, 0);
 860         }
 861         break;
 862     case '\024':                /* ^T */
 863         if (nextchar == '\0') {
 864 #ifdef BIG_TIME
 865             sv_setnv(sv, PL_basetime);
 866 #else
 867             sv_setiv(sv, (IV)PL_basetime);
 868 #endif
 869         }
 870         else if (strEQ(remaining, "AINT"))
 871             sv_setiv(sv, PL_tainting
 872                     ? (PL_taint_warn || PL_unsafe ? -1 : 1)
 873                     : 0);
 874         break;
 875     case '\025':                /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
 876         if (strEQ(remaining, "NICODE"))
 877             sv_setuv(sv, (UV) PL_unicode);
 878         else if (strEQ(remaining, "TF8LOCALE"))
 879             sv_setuv(sv, (UV) PL_utf8locale);
 880         else if (strEQ(remaining, "TF8CACHE"))
 881             sv_setiv(sv, (IV) PL_utf8cache);
 882         break;
 883     case '\027':                /* ^W  & $^WARNING_BITS */
 884         if (nextchar == '\0')
 885             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 886         else if (strEQ(remaining, "ARNING_BITS")) {
 887             if (PL_compiling.cop_warnings == pWARN_NONE) {
 888                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 889             }
 890             else if (PL_compiling.cop_warnings == pWARN_STD) {
 891                 sv_setpvn(
 892                     sv,
 893                     (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
 894                     WARNsize
 895                 );
 896             }
 897             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 898                 /* Get the bit mask for $warnings::Bits{all}, because
 899                  * it could have been extended by warnings::register */
 900                 HV * const bits=get_hv("warnings::Bits", 0);
 901                 if (bits) {
 902                     SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
 903                     if (bits_all)
 904                         sv_setsv(sv, *bits_all);
 905                 }
 906                 else {
 907                     sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 908                 }
 909             }
 910             else {
 911                 sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
 912                           *PL_compiling.cop_warnings);
 913             }
 914             SvPOK_only(sv);
 915         }
 916         break;
 917     case '\015': /* $^MATCH */
 918         if (strEQ(remaining, "ATCH")) {
 919     case '1': case '2': case '3': case '4':
 920     case '5': case '6': case '7': case '8': case '9': case '&':
 921             if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 922                 /*
 923                  * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
 924                  * XXX Does the new way break anything?
 925                  */
 926                 paren = atoi(mg->mg_ptr); /* $& is in [0] */
 927                 CALLREG_NUMBUF_FETCH(rx,paren,sv);
 928                 break;
 929             }
 930             sv_setsv(sv,&PL_sv_undef);
 931         }
 932         break;
 933     case '+':
 934         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 935             if (RX_LASTPAREN(rx)) {
 936                 CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
 937                 break;
 938             }
 939         }
 940         sv_setsv(sv,&PL_sv_undef);
 941         break;
 942     case '\016':                /* ^N */
 943         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 944             if (RX_LASTCLOSEPAREN(rx)) {
 945                 CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
 946                 break;
 947             }
 948
 949         }
 950         sv_setsv(sv,&PL_sv_undef);
 951         break;
 952     case '`':
 953       do_prematch_fetch:
 954         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 955             CALLREG_NUMBUF_FETCH(rx,-2,sv);
 956             break;
 957         }
 958         sv_setsv(sv,&PL_sv_undef);
 959         break;
 960     case '\'':
 961       do_postmatch_fetch:
 962         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 963             CALLREG_NUMBUF_FETCH(rx,-1,sv);
 964             break;
 965         }
 966         sv_setsv(sv,&PL_sv_undef);
 967         break;
 968     case '.':
 969         if (GvIO(PL_last_in_gv)) {
 970             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 971         }
 972         break;
 973     case '?':
 974         {
 975             sv_setiv(sv, (IV)STATUS_CURRENT);
 976 #ifdef COMPLEX_STATUS
 977             LvTARGOFF(sv) = PL_statusvalue;
 978             LvTARGLEN(sv) = PL_statusvalue_vms;
 979 #endif
 980         }
 981         break;
 982     case '^':
 983         if (GvIOp(PL_defoutgv))
 984             s = IoTOP_NAME(GvIOp(PL_defoutgv));
 985         if (s)
 986             sv_setpv(sv,s);
 987         else {
 988             sv_setpv(sv,GvENAME(PL_defoutgv));
 989             sv_catpvs(sv,"_TOP");
 990         }
 991         break;
 992     case '~':
 993         if (GvIOp(PL_defoutgv))
 994             s = IoFMT_NAME(GvIOp(PL_defoutgv));
 995         if (!s)
 996             s = GvENAME(PL_defoutgv);
 997         sv_setpv(sv,s);
 998         break;
 999     case '=':
1000         if (GvIOp(PL_defoutgv))
1001             sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
1002         break;
1003     case '-':
1004         if (GvIOp(PL_defoutgv))
1005             sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
1006         break;
1007     case '%':
1008         if (GvIOp(PL_defoutgv))
1009             sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
1010         break;
1011     case ':':
1012         break;
1013     case '/':
1014         break;
1015     case '[':
1016         sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
1017         break;
1018     case '|':
1019         if (GvIOp(PL_defoutgv))
1020             sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
1021         break;
1022     case '\\':
1023         if (PL_ors_sv)
1024             sv_copypv(sv, PL_ors_sv);
1025         break;
1026     case '!':
1027 #ifdef VMS
1028         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
1029         sv_setpv(sv, errno ? Strerror(errno) : "");
1030 #else
1031         {
1032         dSAVE_ERRNO;
1033         sv_setnv(sv, (NV)errno);
1034 #ifdef OS2
1035         if (errno == errno_isOS2 || errno == errno_isOS2_set)
1036             sv_setpv(sv, os2error(Perl_rc));
1037         else
1038 #endif
1039         sv_setpv(sv, errno ? Strerror(errno) : "");
1040         RESTORE_ERRNO;
1041         }
1042 #endif
1043         SvRTRIM(sv);
1044         SvNOK_on(sv);   /* what a wonderful hack! */
1045         break;
1046     case '<':
1047         sv_setiv(sv, (IV)PL_uid);
1048         break;
1049     case '>':
1050         sv_setiv(sv, (IV)PL_euid);
1051         break;
1052     case '(':
1053         sv_setiv(sv, (IV)PL_gid);
1054         goto add_groups;
1055     case ')':
1056         sv_setiv(sv, (IV)PL_egid);
1057       add_groups:
1058 #ifdef HAS_GETGROUPS
1059         {
1060             Groups_t *gary = NULL;
1061             I32 i, num_groups = getgroups(0, gary);
1062             Newx(gary, num_groups, Groups_t);
1063             num_groups = getgroups(num_groups, gary);
1064             for (i = 0; i < num_groups; i++)
1065                 Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
1066             Safefree(gary);
1067         }
1068         (void)SvIOK_on(sv);     /* what a wonderful hack! */
1069 #endif
1070         break;
1071     case '0':
1072         break;
1073     }
1074     return 0;
1075 }
1076
1077 int
1078 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
1079 {
1080     struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
1081
1082     PERL_ARGS_ASSERT_MAGIC_GETUVAR;
1083
1084     if (uf && uf->uf_val)
1085         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
1086     return 0;
1087 }
1088
1089 int
1090 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
1091 {
1092     dVAR;
1093     STRLEN len = 0, klen;
1094     const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
1095     const char * const ptr = MgPV_const(mg,klen);
1096     my_setenv(ptr, s);
1097
1098     PERL_ARGS_ASSERT_MAGIC_SETENV;
1099
1100 #ifdef DYNAMIC_ENV_FETCH
1101      /* We just undefd an environment var.  Is a replacement */
1102      /* waiting in the wings? */
1103     if (!len) {
1104         SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
1105         if (valp)
1106             s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
1107     }
1108 #endif
1109
1110 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
1111                             /* And you'll never guess what the dog had */
1112                             /*   in its mouth... */
1113     if (PL_tainting) {
1114         MgTAINTEDDIR_off(mg);
1115 #ifdef VMS
1116         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
1117             char pathbuf[256], eltbuf[256], *cp, *elt;
1118             Stat_t sbuf;
1119             int i = 0, j = 0;
1120
1121             my_strlcpy(eltbuf, s, sizeof(eltbuf));
1122             elt = eltbuf;
1123             do {          /* DCL$PATH may be a search list */
1124                 while (1) {   /* as may dev portion of any element */
1125                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
1126                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
1127                              cando_by_name(S_IWUSR,0,elt) ) {
1128                             MgTAINTEDDIR_on(mg);
1129                             return 0;
1130                         }
1131                     }
1132                     if ((cp = strchr(elt, ':')) != NULL)
1133                         *cp = '\0';
1134                     if (my_trnlnm(elt, eltbuf, j++))
1135                         elt = eltbuf;
1136                     else
1137                         break;
1138                 }
1139                 j = 0;
1140             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
1141         }
1142 #endif /* VMS */
1143         if (s && klen == 4 && strEQ(ptr,"PATH")) {
1144             const char * const strend = s + len;
1145
1146             while (s < strend) {
1147                 char tmpbuf[256];
1148                 Stat_t st;
1149                 I32 i;
1150 #ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
1151                 const char path_sep = '|';
1152 #else
1153                 const char path_sep = ':';
1154 #endif
1155                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
1156                              s, strend, path_sep, &i);
1157                 s++;
1158                 if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
1159 #ifdef VMS
1160                       || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
1161 #else
1162                       || *tmpbuf != '/'       /* no starting slash -- assume relative path */
1163 #endif
1164                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
1165                     MgTAINTEDDIR_on(mg);
1166                     return 0;
1167                 }
1168             }
1169         }
1170     }
1171 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
1172
1173     return 0;
1174 }
1175
1176 int
1177 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
1178 {
1179     PERL_ARGS_ASSERT_MAGIC_CLEARENV;
1180     PERL_UNUSED_ARG(sv);
1181     my_setenv(MgPV_nolen_const(mg),NULL);
1182     return 0;
1183 }
1184
1185 int
1186 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
1187 {
1188     dVAR;
1189     PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
1190     PERL_UNUSED_ARG(mg);
1191 #if defined(VMS)
1192     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1193 #else
1194     if (PL_localizing) {
1195         HE* entry;
1196         my_clearenv();
1197         hv_iterinit(MUTABLE_HV(sv));
1198         while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
1199             I32 keylen;
1200             my_setenv(hv_iterkey(entry, &keylen),
1201                       SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
1202         }
1203     }
1204 #endif
1205     return 0;
1206 }
1207
1208 int
1209 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1210 {
1211     dVAR;
1212     PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
1213     PERL_UNUSED_ARG(sv);
1214     PERL_UNUSED_ARG(mg);
1215 #if defined(VMS)
1216     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1217 #else
1218     my_clearenv();
1219 #endif
1220     return 0;
1221 }
1222
1223 #ifndef PERL_MICRO
1224 #ifdef HAS_SIGPROCMASK
1225 static void
1226 restore_sigmask(pTHX_ SV *save_sv)
1227 {
1228     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
1229     (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
1230 }
1231 #endif
1232 int
1233 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1234 {
1235     dVAR;
1236     /* Are we fetching a signal entry? */
1237     const I32 i = whichsig(MgPV_nolen_const(mg));
1238
1239     PERL_ARGS_ASSERT_MAGIC_GETSIG;
1240
1241     if (i > 0) {
1242         if(PL_psig_ptr[i])
1243             sv_setsv(sv,PL_psig_ptr[i]);
1244         else {
1245             Sighandler_t sigstate = rsignal_state(i);
1246 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1247             if (PL_sig_handlers_initted && PL_sig_ignoring[i])
1248                 sigstate = SIG_IGN;
1249 #endif
1250 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1251             if (PL_sig_handlers_initted && PL_sig_defaulting[i])
1252                 sigstate = SIG_DFL;
1253 #endif
1254             /* cache state so we don't fetch it again */
1255             if(sigstate == (Sighandler_t) SIG_IGN)
1256                 sv_setpvs(sv,"IGNORE");
1257             else
1258                 sv_setsv(sv,&PL_sv_undef);
1259             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1260             SvTEMP_off(sv);
1261         }
1262     }
1263     return 0;
1264 }
1265 int
1266 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1267 {
1268     PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
1269     PERL_UNUSED_ARG(sv);
1270
1271     magic_setsig(NULL, mg);
1272     return sv_unmagic(sv, mg->mg_type);
1273 }
1274
1275 Signal_t
1276 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1277 Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
1278 #else
1279 Perl_csighandler(int sig)
1280 #endif
1281 {
1282 #ifdef PERL_GET_SIG_CONTEXT
1283     dTHXa(PERL_GET_SIG_CONTEXT);
1284 #else
1285     dTHX;
1286 #endif
1287 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1288     (void) rsignal(sig, PL_csighandlerp);
1289     if (PL_sig_ignoring[sig]) return;
1290 #endif
1291 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1292     if (PL_sig_defaulting[sig])
1293 #ifdef KILL_BY_SIGPRC
1294             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1295 #else
1296             exit(1);
1297 #endif
1298 #endif
1299     if (
1300 #ifdef SIGILL
1301            sig == SIGILL ||
1302 #endif
1303 #ifdef SIGBUS
1304            sig == SIGBUS ||
1305 #endif
1306 #ifdef SIGSEGV
1307            sig == SIGSEGV ||
1308 #endif
1309            (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
1310         /* Call the perl level handler now--
1311          * with risk we may be in malloc() etc. */
1312 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1313         (*PL_sighandlerp)(sig, NULL, NULL);
1314 #else
1315         (*PL_sighandlerp)(sig);
1316 #endif
1317     else {
1318         /* Set a flag to say this signal is pending, that is awaiting delivery after
1319          * the current Perl opcode completes */
1320         PL_psig_pend[sig]++;
1321
1322 #ifndef SIG_PENDING_DIE_COUNT
1323 #  define SIG_PENDING_DIE_COUNT 120
1324 #endif
1325         /* And one to say _a_ signal is pending */
1326         if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
1327             Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
1328                        (unsigned long)SIG_PENDING_DIE_COUNT);
1329     }
1330 }
1331
1332 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1333 void
1334 Perl_csighandler_init(void)
1335 {
1336     int sig;
1337     if (PL_sig_handlers_initted) return;
1338
1339     for (sig = 1; sig < SIG_SIZE; sig++) {
1340 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1341         dTHX;
1342         PL_sig_defaulting[sig] = 1;
1343         (void) rsignal(sig, PL_csighandlerp);
1344 #endif
1345 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1346         PL_sig_ignoring[sig] = 0;
1347 #endif
1348     }
1349     PL_sig_handlers_initted = 1;
1350 }
1351 #endif
1352
1353 void
1354 Perl_despatch_signals(pTHX)
1355 {
1356     dVAR;
1357     int sig;
1358     PL_sig_pending = 0;
1359     for (sig = 1; sig < SIG_SIZE; sig++) {
1360         if (PL_psig_pend[sig]) {
1361             PERL_BLOCKSIG_ADD(set, sig);
1362             PL_psig_pend[sig] = 0;
1363             PERL_BLOCKSIG_BLOCK(set);
1364 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
1365             (*PL_sighandlerp)(sig, NULL, NULL);
1366 #else
1367             (*PL_sighandlerp)(sig);
1368 #endif
1369             PERL_BLOCKSIG_UNBLOCK(set);
1370         }
1371     }
1372 }
1373
1374 /* sv of NULL signifies that we're acting as magic_clearsig.  */
1375 int
1376 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1377 {
1378     dVAR;
1379     I32 i;
1380     SV** svp = NULL;
1381     /* Need to be careful with SvREFCNT_dec(), because that can have side
1382      * effects (due to closures). We must make sure that the new disposition
1383      * is in place before it is called.
1384      */
1385     SV* to_dec = NULL;
1386     STRLEN len;
1387 #ifdef HAS_SIGPROCMASK
1388     sigset_t set, save;
1389     SV* save_sv;
1390 #endif
1391     register const char *s = MgPV_const(mg,len);
1392
1393     PERL_ARGS_ASSERT_MAGIC_SETSIG;
1394
1395     if (*s == '_') {
1396         if (strEQ(s,"__DIE__"))
1397             svp = &PL_diehook;
1398         else if (strEQ(s,"__WARN__")
1399                  && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
1400             /* Merge the existing behaviours, which are as follows:
1401                magic_setsig, we always set svp to &PL_warnhook
1402                (hence we always change the warnings handler)
1403                For magic_clearsig, we don't change the warnings handler if it's
1404                set to the &PL_warnhook.  */
1405             svp = &PL_warnhook;
1406         } else if (sv)
1407             Perl_croak(aTHX_ "No such hook: %s", s);
1408         i = 0;
1409         if (svp && *svp) {
1410             if (*svp != PERL_WARNHOOK_FATAL)
1411                 to_dec = *svp;
1412             *svp = NULL;
1413         }
1414     }
1415     else {
1416         i = whichsig(s);        /* ...no, a brick */
1417         if (i <= 0) {
1418             if (sv && ckWARN(WARN_SIGNAL))
1419                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1420             return 0;
1421         }
1422 #ifdef HAS_SIGPROCMASK
1423         /* Avoid having the signal arrive at a bad time, if possible. */
1424         sigemptyset(&set);
1425         sigaddset(&set,i);
1426         sigprocmask(SIG_BLOCK, &set, &save);
1427         ENTER;
1428         save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
1429         SAVEFREESV(save_sv);
1430         SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
1431 #endif
1432         PERL_ASYNC_CHECK();
1433 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1434         if (!PL_sig_handlers_initted) Perl_csighandler_init();
1435 #endif
1436 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1437         PL_sig_ignoring[i] = 0;
1438 #endif
1439 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1440         PL_sig_defaulting[i] = 0;
1441 #endif
1442         to_dec = PL_psig_ptr[i];
1443         if (sv) {
1444             PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
1445             SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1446
1447             /* Signals don't change name during the program's execution, so once
1448                they're cached in the appropriate slot of PL_psig_name, they can
1449                stay there.
1450
1451                Ideally we'd find some way of making SVs at (C) compile time, or
1452                at least, doing most of the work.  */
1453             if (!PL_psig_name[i]) {
1454                 PL_psig_name[i] = newSVpvn(s, len);
1455                 SvREADONLY_on(PL_psig_name[i]);
1456             }
1457         } else {
1458             SvREFCNT_dec(PL_psig_name[i]);
1459             PL_psig_name[i] = NULL;
1460             PL_psig_ptr[i] = NULL;
1461         }
1462     }
1463     if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
1464         if (i) {
1465             (void)rsignal(i, PL_csighandlerp);
1466         }
1467         else
1468             *svp = SvREFCNT_inc_simple_NN(sv);
1469     } else {
1470         if (sv && SvOK(sv)) {
1471             s = SvPV_force(sv, len);
1472         } else {
1473             sv = NULL;
1474         }
1475         if (sv && strEQ(s,"IGNORE")) {
1476             if (i) {
1477 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1478                 PL_sig_ignoring[i] = 1;
1479                 (void)rsignal(i, PL_csighandlerp);
1480 #else
1481                 (void)rsignal(i, (Sighandler_t) SIG_IGN);
1482 #endif
1483             }
1484         }
1485         else if (!sv || strEQ(s,"DEFAULT") || !len) {
1486             if (i) {
1487 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1488                 PL_sig_defaulting[i] = 1;
1489                 (void)rsignal(i, PL_csighandlerp);
1490 #else
1491                 (void)rsignal(i, (Sighandler_t) SIG_DFL);
1492 #endif
1493             }
1494         }
1495         else {
1496             /*
1497              * We should warn if HINT_STRICT_REFS, but without
1498              * access to a known hint bit in a known OP, we can't
1499              * tell whether HINT_STRICT_REFS is in force or not.
1500              */
1501             if (!strchr(s,':') && !strchr(s,'\''))
1502                 Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
1503                                      SV_GMAGIC);
1504             if (i)
1505                 (void)rsignal(i, PL_csighandlerp);
1506             else
1507                 *svp = SvREFCNT_inc_simple_NN(sv);
1508         }
1509     }
1510
1511 #ifdef HAS_SIGPROCMASK
1512     if(i)
1513         LEAVE;
1514 #endif
1515     if(to_dec)
1516         SvREFCNT_dec(to_dec);
1517     return 0;
1518 }
1519 #endif /* !PERL_MICRO */
1520
1521 int
1522 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1523 {
1524     dVAR;
1525     HV* stash;
1526
1527     PERL_ARGS_ASSERT_MAGIC_SETISA;
1528     PERL_UNUSED_ARG(sv);
1529
1530     /* Bail out if destruction is going on */
1531     if(PL_dirty) return 0;
1532
1533     /* Skip _isaelem because _isa will handle it shortly */
1534     if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
1535         return 0;
1536
1537     /* XXX Once it's possible, we need to
1538        detect that our @ISA is aliased in
1539        other stashes, and act on the stashes
1540        of all of the aliases */
1541
1542     /* The first case occurs via setisa,
1543        the second via setisa_elem, which
1544        calls this same magic */
1545     stash = GvSTASH(
1546         SvTYPE(mg->mg_obj) == SVt_PVGV
1547             ? (const GV *)mg->mg_obj
1548             : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
1549     );
1550
1551     if (stash)
1552         mro_isa_changed_in(stash);
1553
1554     return 0;
1555 }
1556
1557 int
1558 Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
1559 {
1560     dVAR;
1561     HV* stash;
1562
1563     PERL_ARGS_ASSERT_MAGIC_CLEARISA;
1564
1565     /* Bail out if destruction is going on */
1566     if(PL_dirty) return 0;
1567
1568     av_clear(MUTABLE_AV(sv));
1569
1570     /* XXX see comments in magic_setisa */
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         DEBUG_x(dump_all());
2338 #else
2339         PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
2340 #endif
2341         break;
2342     case '\005':  /* ^E */
2343         if (*(mg->mg_ptr+1) == '\0') {
2344 #ifdef VMS
2345             set_vaxc_errno(SvIV(sv));
2346 #else
2347 #  ifdef WIN32
2348             SetLastError( SvIV(sv) );
2349 #  else
2350 #    ifdef OS2
2351             os2_setsyserrno(SvIV(sv));
2352 #    else
2353             /* will anyone ever use this? */
2354             SETERRNO(SvIV(sv), 4);
2355 #    endif
2356 #  endif
2357 #endif
2358         }
2359         else if (strEQ(mg->mg_ptr+1, "NCODING")) {
2360             if (PL_encoding)
2361                 SvREFCNT_dec(PL_encoding);
2362             if (SvOK(sv) || SvGMAGICAL(sv)) {
2363                 PL_encoding = newSVsv(sv);
2364             }
2365             else {
2366                 PL_encoding = NULL;
2367             }
2368         }
2369         break;
2370     case '\006':        /* ^F */
2371         PL_maxsysfd = SvIV(sv);
2372         break;
2373     case '\010':        /* ^H */
2374         PL_hints = SvIV(sv);
2375         break;
2376     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
2377         Safefree(PL_inplace);
2378         PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
2379         break;
2380     case '\017':        /* ^O */
2381         if (*(mg->mg_ptr+1) == '\0') {
2382             Safefree(PL_osname);
2383             PL_osname = NULL;
2384             if (SvOK(sv)) {
2385                 TAINT_PROPER("assigning to $^O");
2386                 PL_osname = savesvpv(sv);
2387             }
2388         }
2389         else if (strEQ(mg->mg_ptr, "\017PEN")) {
2390             STRLEN len;
2391             const char *const start = SvPV(sv, len);
2392             const char *out = (const char*)memchr(start, '\0', len);
2393             SV *tmp;
2394             struct refcounted_he *tmp_he;
2395
2396
2397             PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2398             PL_hints
2399                 |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
2400
2401             /* Opening for input is more common than opening for output, so
2402                ensure that hints for input are sooner on linked list.  */
2403             tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
2404                                        SVs_TEMP | SvUTF8(sv))
2405                 : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
2406
2407             tmp_he
2408                 = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
2409                                          newSVpvs_flags("open>", SVs_TEMP),
2410                                          tmp);
2411
2412             /* The UTF-8 setting is carried over  */
2413             sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
2414
2415             PL_compiling.cop_hints_hash
2416                 = Perl_refcounted_he_new(aTHX_ tmp_he,
2417                                          newSVpvs_flags("open<", SVs_TEMP),
2418                                          tmp);
2419         }
2420         break;
2421     case '\020':        /* ^P */
2422       if (*remaining == '\0') { /* ^P */
2423           PL_perldb = SvIV(sv);
2424           if (PL_perldb && !PL_DBsingle)
2425               init_debugger();
2426           break;
2427       } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
2428           goto do_prematch;
2429       } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
2430           goto do_postmatch;
2431       }
2432     case '\024':        /* ^T */
2433 #ifdef BIG_TIME
2434         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
2435 #else
2436         PL_basetime = (Time_t)SvIV(sv);
2437 #endif
2438         break;
2439     case '\025':        /* ^UTF8CACHE */
2440          if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
2441              PL_utf8cache = (signed char) sv_2iv(sv);
2442          }
2443          break;
2444     case '\027':        /* ^W & $^WARNING_BITS */
2445         if (*(mg->mg_ptr+1) == '\0') {
2446             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2447                 i = SvIV(sv);
2448                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
2449                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
2450             }
2451         }
2452         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
2453             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
2454                 if (!SvPOK(sv) && PL_localizing) {
2455                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
2456                     PL_compiling.cop_warnings = pWARN_NONE;
2457                     break;
2458                 }
2459                 {
2460                     STRLEN len, i;
2461                     int accumulate = 0 ;
2462                     int any_fatals = 0 ;
2463                     const char * const ptr = SvPV_const(sv, len) ;
2464                     for (i = 0 ; i < len ; ++i) {
2465                         accumulate |= ptr[i] ;
2466                         any_fatals |= (ptr[i] & 0xAA) ;
2467                     }
2468                     if (!accumulate) {
2469                         if (!specialWARN(PL_compiling.cop_warnings))
2470                             PerlMemShared_free(PL_compiling.cop_warnings);
2471                         PL_compiling.cop_warnings = pWARN_NONE;
2472                     }
2473                     /* Yuck. I can't see how to abstract this:  */
2474                     else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
2475                                        WARN_ALL) && !any_fatals) {
2476                         if (!specialWARN(PL_compiling.cop_warnings))
2477                             PerlMemShared_free(PL_compiling.cop_warnings);
2478                         PL_compiling.cop_warnings = pWARN_ALL;
2479                         PL_dowarn |= G_WARN_ONCE ;
2480                     }
2481                     else {
2482                         STRLEN len;
2483                         const char *const p = SvPV_const(sv, len);
2484
2485                         PL_compiling.cop_warnings
2486                             = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
2487                                                          p, len);
2488
2489                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
2490                             PL_dowarn |= G_WARN_ONCE ;
2491                     }
2492
2493                 }
2494             }
2495         }
2496         break;
2497     case '.':
2498         if (PL_localizing) {
2499             if (PL_localizing == 1)
2500                 SAVESPTR(PL_last_in_gv);
2501         }
2502         else if (SvOK(sv) && GvIO(PL_last_in_gv))
2503             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
2504         break;
2505     case '^':
2506         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
2507         s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2508         IoTOP_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2509         break;
2510     case '~':
2511         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
2512         s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
2513         IoFMT_GV(GvIOp(PL_defoutgv)) =  gv_fetchsv(sv, GV_ADD, SVt_PVIO);
2514         break;
2515     case '=':
2516         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
2517         break;
2518     case '-':
2519         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
2520         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
2521             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
2522         break;
2523     case '%':
2524         IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
2525         break;
2526     case '|':
2527         {
2528             IO * const io = GvIOp(PL_defoutgv);
2529             if(!io)
2530               break;
2531             if ((SvIV(sv)) == 0)
2532                 IoFLAGS(io) &= ~IOf_FLUSH;
2533             else {
2534                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2535                     PerlIO *ofp = IoOFP(io);
2536                     if (ofp)
2537                         (void)PerlIO_flush(ofp);
2538                     IoFLAGS(io) |= IOf_FLUSH;
2539                 }
2540             }
2541         }
2542         break;
2543     case '/':
2544         SvREFCNT_dec(PL_rs);
2545         PL_rs = newSVsv(sv);
2546         break;
2547     case '\\':
2548         if (PL_ors_sv)
2549             SvREFCNT_dec(PL_ors_sv);
2550         if (SvOK(sv) || SvGMAGICAL(sv)) {
2551             PL_ors_sv = newSVsv(sv);
2552         }
2553         else {
2554             PL_ors_sv = NULL;
2555         }
2556         break;
2557     case '[':
2558         CopARYBASE_set(&PL_compiling, SvIV(sv));
2559         break;
2560     case '?':
2561 #ifdef COMPLEX_STATUS
2562         if (PL_localizing == 2) {
2563             PL_statusvalue = LvTARGOFF(sv);
2564             PL_statusvalue_vms = LvTARGLEN(sv);
2565         }
2566         else
2567 #endif
2568 #ifdef VMSISH_STATUS
2569         if (VMSISH_STATUS)
2570             STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
2571         else
2572 #endif
2573             STATUS_UNIX_EXIT_SET(SvIV(sv));
2574         break;
2575     case '!':
2576         {
2577 #ifdef VMS
2578 #   define PERL_VMS_BANG vaxc$errno
2579 #else
2580 #   define PERL_VMS_BANG 0
2581 #endif
2582         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2583                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2584         }
2585         break;
2586     case '<':
2587         PL_uid = SvIV(sv);
2588         if (PL_delaymagic) {
2589             PL_delaymagic |= DM_RUID;
2590             break;                              /* don't do magic till later */
2591         }
2592 #ifdef HAS_SETRUID
2593         (void)setruid((Uid_t)PL_uid);
2594 #else
2595 #ifdef HAS_SETREUID
2596         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2597 #else
2598 #ifdef HAS_SETRESUID
2599       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2600 #else
2601         if (PL_uid == PL_euid) {                /* special case $< = $> */
2602 #ifdef PERL_DARWIN
2603             /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
2604             if (PL_uid != 0 && PerlProc_getuid() == 0)
2605                 (void)PerlProc_setuid(0);
2606 #endif
2607             (void)PerlProc_setuid(PL_uid);
2608         } else {
2609             PL_uid = PerlProc_getuid();
2610             Perl_croak(aTHX_ "setruid() not implemented");
2611         }
2612 #endif
2613 #endif
2614 #endif
2615         PL_uid = PerlProc_getuid();
2616         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2617         break;
2618     case '>':
2619         PL_euid = SvIV(sv);
2620         if (PL_delaymagic) {
2621             PL_delaymagic |= DM_EUID;
2622             break;                              /* don't do magic till later */
2623         }
2624 #ifdef HAS_SETEUID
2625         (void)seteuid((Uid_t)PL_euid);
2626 #else
2627 #ifdef HAS_SETREUID
2628         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2629 #else
2630 #ifdef HAS_SETRESUID
2631         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2632 #else
2633         if (PL_euid == PL_uid)          /* special case $> = $< */
2634             PerlProc_setuid(PL_euid);
2635         else {
2636             PL_euid = PerlProc_geteuid();
2637             Perl_croak(aTHX_ "seteuid() not implemented");
2638         }
2639 #endif
2640 #endif
2641 #endif
2642         PL_euid = PerlProc_geteuid();
2643         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2644         break;
2645     case '(':
2646         PL_gid = SvIV(sv);
2647         if (PL_delaymagic) {
2648             PL_delaymagic |= DM_RGID;
2649             break;                              /* don't do magic till later */
2650         }
2651 #ifdef HAS_SETRGID
2652         (void)setrgid((Gid_t)PL_gid);
2653 #else
2654 #ifdef HAS_SETREGID
2655         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2656 #else
2657 #ifdef HAS_SETRESGID
2658       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2659 #else
2660         if (PL_gid == PL_egid)                  /* special case $( = $) */
2661             (void)PerlProc_setgid(PL_gid);
2662         else {
2663             PL_gid = PerlProc_getgid();
2664             Perl_croak(aTHX_ "setrgid() not implemented");
2665         }
2666 #endif
2667 #endif
2668 #endif
2669         PL_gid = PerlProc_getgid();
2670         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2671         break;
2672     case ')':
2673 #ifdef HAS_SETGROUPS
2674         {
2675             const char *p = SvPV_const(sv, len);
2676             Groups_t *gary = NULL;
2677
2678             while (isSPACE(*p))
2679                 ++p;
2680             PL_egid = Atol(p);
2681             for (i = 0; i < NGROUPS; ++i) {
2682                 while (*p && !isSPACE(*p))
2683                     ++p;
2684                 while (isSPACE(*p))
2685                     ++p;
2686                 if (!*p)
2687                     break;
2688                 if(!gary)
2689                     Newx(gary, i + 1, Groups_t);
2690                 else
2691                     Renew(gary, i + 1, Groups_t);
2692                 gary[i] = Atol(p);
2693             }
2694             if (i)
2695                 (void)setgroups(i, gary);
2696             Safefree(gary);
2697         }
2698 #else  /* HAS_SETGROUPS */
2699         PL_egid = SvIV(sv);
2700 #endif /* HAS_SETGROUPS */
2701         if (PL_delaymagic) {
2702             PL_delaymagic |= DM_EGID;
2703             break;                              /* don't do magic till later */
2704         }
2705 #ifdef HAS_SETEGID
2706         (void)setegid((Gid_t)PL_egid);
2707 #else
2708 #ifdef HAS_SETREGID
2709         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2710 #else
2711 #ifdef HAS_SETRESGID
2712         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2713 #else
2714         if (PL_egid == PL_gid)                  /* special case $) = $( */
2715             (void)PerlProc_setgid(PL_egid);
2716         else {
2717             PL_egid = PerlProc_getegid();
2718             Perl_croak(aTHX_ "setegid() not implemented");
2719         }
2720 #endif
2721 #endif
2722 #endif
2723         PL_egid = PerlProc_getegid();
2724         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2725         break;
2726     case ':':
2727         PL_chopset = SvPV_force(sv,len);
2728         break;
2729     case '0':
2730         LOCK_DOLLARZERO_MUTEX;
2731 #ifdef HAS_SETPROCTITLE
2732         /* The BSDs don't show the argv[] in ps(1) output, they
2733          * show a string from the process struct and provide
2734          * the setproctitle() routine to manipulate that. */
2735         if (PL_origalen != 1) {
2736             s = SvPV_const(sv, len);
2737 #   if __FreeBSD_version > 410001
2738             /* The leading "-" removes the "perl: " prefix,
2739              * but not the "(perl) suffix from the ps(1)
2740              * output, because that's what ps(1) shows if the
2741              * argv[] is modified. */
2742             setproctitle("-%s", s);
2743 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2744             /* This doesn't really work if you assume that
2745              * $0 = 'foobar'; will wipe out 'perl' from the $0
2746              * because in ps(1) output the result will be like
2747              * sprintf("perl: %s (perl)", s)
2748              * I guess this is a security feature:
2749              * one (a user process) cannot get rid of the original name.
2750              * --jhi */
2751             setproctitle("%s", s);
2752 #   endif
2753         }
2754 #elif defined(__hpux) && defined(PSTAT_SETCMD)
2755         if (PL_origalen != 1) {
2756              union pstun un;
2757              s = SvPV_const(sv, len);
2758              un.pst_command = (char *)s;
2759              pstat(PSTAT_SETCMD, un, len, 0, 0);
2760         }
2761 #else
2762         if (PL_origalen > 1) {
2763             /* PL_origalen is set in perl_parse(). */
2764             s = SvPV_force(sv,len);
2765             if (len >= (STRLEN)PL_origalen-1) {
2766                 /* Longer than original, will be truncated. We assume that
2767                  * PL_origalen bytes are available. */
2768                 Copy(s, PL_origargv[0], PL_origalen-1, char);
2769             }
2770             else {
2771                 /* Shorter than original, will be padded. */
2772 #ifdef PERL_DARWIN
2773                 /* Special case for Mac OS X: see [perl #38868] */
2774                 const int pad = 0;
2775 #else
2776                 /* Is the space counterintuitive?  Yes.
2777                  * (You were expecting \0?)
2778                  * Does it work?  Seems to.  (In Linux 2.4.20 at least.)
2779                  * --jhi */
2780                 const int pad = ' ';
2781 #endif
2782                 Copy(s, PL_origargv[0], len, char);
2783                 PL_origargv[0][len] = 0;
2784                 memset(PL_origargv[0] + len + 1,
2785                        pad,  PL_origalen - len - 1);
2786             }
2787             PL_origargv[0][PL_origalen-1] = 0;
2788             for (i = 1; i < PL_origargc; i++)
2789                 PL_origargv[i] = 0;
2790         }
2791 #endif
2792         UNLOCK_DOLLARZERO_MUTEX;
2793         break;
2794     }
2795     return 0;
2796 }
2797
2798 I32
2799 Perl_whichsig(pTHX_ const char *sig)
2800 {
2801     register char* const* sigv;
2802
2803     PERL_ARGS_ASSERT_WHICHSIG;
2804     PERL_UNUSED_CONTEXT;
2805
2806     for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
2807         if (strEQ(sig,*sigv))
2808             return PL_sig_num[sigv - (char* const*)PL_sig_name];
2809 #ifdef SIGCLD
2810     if (strEQ(sig,"CHLD"))
2811         return SIGCLD;
2812 #endif
2813 #ifdef SIGCHLD
2814     if (strEQ(sig,"CLD"))
2815         return SIGCHLD;
2816 #endif
2817     return -1;
2818 }
2819
2820 Signal_t
2821 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2822 Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
2823 #else
2824 Perl_sighandler(int sig)
2825 #endif
2826 {
2827 #ifdef PERL_GET_SIG_CONTEXT
2828     dTHXa(PERL_GET_SIG_CONTEXT);
2829 #else
2830     dTHX;
2831 #endif
2832     dSP;
2833     GV *gv = NULL;
2834     SV *sv = NULL;
2835     SV * const tSv = PL_Sv;
2836     CV *cv = NULL;
2837     OP *myop = PL_op;
2838     U32 flags = 0;
2839     XPV * const tXpv = PL_Xpv;
2840
2841     if (PL_savestack_ix + 15 <= PL_savestack_max)
2842         flags |= 1;
2843     if (PL_markstack_ptr < PL_markstack_max - 2)
2844         flags |= 4;
2845     if (PL_scopestack_ix < PL_scopestack_max - 3)
2846         flags |= 16;
2847
2848     if (!PL_psig_ptr[sig]) {
2849                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2850                                  PL_sig_name[sig]);
2851                 exit(sig);
2852         }
2853
2854     /* Max number of items pushed there is 3*n or 4. We cannot fix
2855        infinity, so we fix 4 (in fact 5): */
2856     if (flags & 1) {
2857         PL_savestack_ix += 5;           /* Protect save in progress. */
2858         SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
2859     }
2860     if (flags & 4)
2861         PL_markstack_ptr++;             /* Protect mark. */
2862     if (flags & 16)
2863         PL_scopestack_ix += 1;
2864     /* sv_2cv is too complicated, try a simpler variant first: */
2865     if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
2866         || SvTYPE(cv) != SVt_PVCV) {
2867         HV *st;
2868         cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
2869     }
2870
2871     if (!cv || !CvROOT(cv)) {
2872         if (ckWARN(WARN_SIGNAL))
2873             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2874                 PL_sig_name[sig], (gv ? GvENAME(gv)
2875                                 : ((cv && CvGV(cv))
2876                                    ? GvENAME(CvGV(cv))
2877                                    : "__ANON__")));
2878         goto cleanup;
2879     }
2880
2881     if(PL_psig_name[sig]) {
2882         sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
2883         flags |= 64;
2884 #if !defined(PERL_IMPLICIT_CONTEXT)
2885         PL_sig_sv = sv;
2886 #endif
2887     } else {
2888         sv = sv_newmortal();
2889         sv_setpv(sv,PL_sig_name[sig]);
2890     }
2891
2892     PUSHSTACKi(PERLSI_SIGNAL);
2893     PUSHMARK(SP);
2894     PUSHs(sv);
2895 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
2896     {
2897          struct sigaction oact;
2898
2899          if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
2900               if (sip) {
2901                    HV *sih = newHV();
2902                    SV *rv  = newRV_noinc(MUTABLE_SV(sih));
2903                    /* The siginfo fields signo, code, errno, pid, uid,
2904                     * addr, status, and band are defined by POSIX/SUSv3. */
2905                    (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
2906                    (void)hv_stores(sih, "code", newSViv(sip->si_code));
2907 #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. */
2908                    hv_stores(sih, "errno",      newSViv(sip->si_errno));
2909                    hv_stores(sih, "status",     newSViv(sip->si_status));
2910                    hv_stores(sih, "uid",        newSViv(sip->si_uid));
2911                    hv_stores(sih, "pid",        newSViv(sip->si_pid));
2912                    hv_stores(sih, "addr",       newSVuv(PTR2UV(sip->si_addr)));
2913                    hv_stores(sih, "band",       newSViv(sip->si_band));
2914 #endif
2915                    EXTEND(SP, 2);
2916                    PUSHs(rv);
2917                    mPUSHp((char *)sip, sizeof(*sip));
2918               }
2919
2920          }
2921     }
2922 #endif
2923     PUTBACK;
2924
2925     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
2926
2927     POPSTACK;
2928     if (SvTRUE(ERRSV)) {
2929 #ifndef PERL_MICRO
2930 #ifdef HAS_SIGPROCMASK
2931         /* Handler "died", for example to get out of a restart-able read().
2932          * Before we re-do that on its behalf re-enable the signal which was
2933          * blocked by the system when we entered.
2934          */
2935         sigset_t set;
2936         sigemptyset(&set);
2937         sigaddset(&set,sig);
2938         sigprocmask(SIG_UNBLOCK, &set, NULL);
2939 #else
2940         /* Not clear if this will work */
2941         (void)rsignal(sig, SIG_IGN);
2942         (void)rsignal(sig, PL_csighandlerp);
2943 #endif
2944 #endif /* !PERL_MICRO */
2945         Perl_die(aTHX_ NULL);
2946     }
2947 cleanup:
2948     if (flags & 1)
2949         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2950     if (flags & 4)
2951         PL_markstack_ptr--;
2952     if (flags & 16)
2953         PL_scopestack_ix -= 1;
2954     if (flags & 64)
2955         SvREFCNT_dec(sv);
2956     PL_op = myop;                       /* Apparently not needed... */
2957
2958     PL_Sv = tSv;                        /* Restore global temporaries. */
2959     PL_Xpv = tXpv;
2960     return;
2961 }
2962
2963
2964 static void
2965 S_restore_magic(pTHX_ const void *p)
2966 {
2967     dVAR;
2968     MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
2969     SV* const sv = mgs->mgs_sv;
2970
2971     if (!sv)
2972         return;
2973
2974     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2975     {
2976 #ifdef PERL_OLD_COPY_ON_WRITE
2977         /* While magic was saved (and off) sv_setsv may well have seen
2978            this SV as a prime candidate for COW.  */
2979         if (SvIsCOW(sv))
2980             sv_force_normal_flags(sv, 0);
2981 #endif
2982
2983         if (mgs->mgs_flags)
2984             SvFLAGS(sv) |= mgs->mgs_flags;
2985         else
2986             mg_magical(sv);
2987         if (SvGMAGICAL(sv)) {
2988             /* downgrade public flags to private,
2989                and discard any other private flags */
2990
2991             const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
2992             if (pubflags) {
2993                 SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
2994                 SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
2995             }
2996         }
2997     }
2998
2999     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
3000
3001     /* If we're still on top of the stack, pop us off.  (That condition
3002      * will be satisfied if restore_magic was called explicitly, but *not*
3003      * if it's being called via leave_scope.)
3004      * The reason for doing this is that otherwise, things like sv_2cv()
3005      * may leave alloc gunk on the savestack, and some code
3006      * (e.g. sighandler) doesn't expect that...
3007      */
3008     if (PL_savestack_ix == mgs->mgs_ss_ix)
3009     {
3010         I32 popval = SSPOPINT;
3011         assert(popval == SAVEt_DESTRUCTOR_X);
3012         PL_savestack_ix -= 2;
3013         popval = SSPOPINT;
3014         assert(popval == SAVEt_ALLOC);
3015         popval = SSPOPINT;
3016         PL_savestack_ix -= popval;
3017     }
3018
3019 }
3020
3021 static void
3022 S_unwind_handler_stack(pTHX_ const void *p)
3023 {
3024     dVAR;
3025     const U32 flags = *(const U32*)p;
3026
3027     PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
3028
3029     if (flags & 1)
3030         PL_savestack_ix -= 5; /* Unprotect save in progress. */
3031 #if !defined(PERL_IMPLICIT_CONTEXT)
3032     if (flags & 64)
3033         SvREFCNT_dec(PL_sig_sv);
3034 #endif
3035 }
3036
3037 /*
3038 =for apidoc magic_sethint
3039
3040 Triggered by a store to %^H, records the key/value pair to
3041 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
3042 anything that would need a deep copy.  Maybe we should warn if we find a
3043 reference.
3044
3045 =cut
3046 */
3047 int
3048 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
3049 {
3050     dVAR;
3051     SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
3052         : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
3053
3054     PERL_ARGS_ASSERT_MAGIC_SETHINT;
3055
3056     /* mg->mg_obj isn't being used.  If needed, it would be possible to store
3057        an alternative leaf in there, with PL_compiling.cop_hints being used if
3058        it's NULL. If needed for threads, the alternative could lock a mutex,
3059        or take other more complex action.  */
3060
3061     /* Something changed in %^H, so it will need to be restored on scope exit.
3062        Doing this here saves a lot of doing it manually in perl code (and
3063        forgetting to do it, and consequent subtle errors.  */
3064     PL_hints |= HINT_LOCALIZE_HH;
3065     PL_compiling.cop_hints_hash
3066         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
3067     return 0;
3068 }
3069
3070 /*
3071 =for apidoc magic_clearhint
3072
3073 Triggered by a delete from %^H, records the key to
3074 C<PL_compiling.cop_hints_hash>.
3075
3076 =cut
3077 */
3078 int
3079 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
3080 {
3081     dVAR;
3082
3083     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
3084     PERL_UNUSED_ARG(sv);
3085
3086     assert(mg->mg_len == HEf_SVKEY);
3087
3088     PERL_UNUSED_ARG(sv);
3089
3090     PL_hints |= HINT_LOCALIZE_HH;
3091     PL_compiling.cop_hints_hash
3092         = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
3093                                  MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
3094     return 0;
3095 }
3096
3097 /*
3098  * Local variables:
3099  * c-indentation-style: bsd
3100  * c-basic-offset: 4
3101  * indent-tabs-mode: t
3102  * End:
3103  *
3104  * ex: set ts=8 sts=4 sw=4 noet:
3105  */