mg.c

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