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