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