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