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