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