mg.c

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