mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "Sam sat on the ground and put his head in his hands.  'I wish I had never
  12  * come here, and I don't want to see no more magic,' he said, and fell silent."
  13  */
  14
  15 /*
  16 =head1 Magical Functions
  17 */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_MG_C
  21 #include "perl.h"
  22
  23 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
  24 #  ifndef NGROUPS
  25 #    define NGROUPS 32
  26 #  endif
  27 #  ifdef I_GRP
  28 #    include <grp.h>
  29 #  endif
  30 #endif
  31
  32 /* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
  33 #if !defined(HAS_SIGACTION) && defined(VMS)
  34 #  define  FAKE_PERSISTENT_SIGNAL_HANDLERS
  35 #endif
  36 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
  37 #if defined(KILL_BY_SIGPRC)
  38 #  define  FAKE_DEFAULT_SIGNAL_HANDLERS
  39 #endif
  40
  41 static void restore_magic(pTHX_ void *p);
  42 static void unwind_handler_stack(pTHX_ void *p);
  43
  44 /*
  45  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  46  */
  47
  48 struct magic_state {
  49     SV* mgs_sv;
  50     U32 mgs_flags;
  51     I32 mgs_ss_ix;
  52 };
  53 /* MGS is typedef'ed to struct magic_state in perl.h */
  54
  55 STATIC void
  56 S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
  57 {
  58     MGS* mgs;
  59     assert(SvMAGICAL(sv));
  60 #ifdef PERL_COPY_ON_WRITE
  61     /* Turning READONLY off for a copy-on-write scalar is a bad idea.  */
  62     if (SvIsCOW(sv))
  63       sv_force_normal(sv);
  64 #endif
  65
  66     SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
  67
  68     mgs = SSPTR(mgs_ix, MGS*);
  69     mgs->mgs_sv = sv;
  70     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  71     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
  72
  73     SvMAGICAL_off(sv);
  74     SvREADONLY_off(sv);
  75     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
  76 }
  77
  78 /*
  79 =for apidoc mg_magical
  80
  81 Turns on the magical status of an SV.  See C<sv_magic>.
  82
  83 =cut
  84 */
  85
  86 void
  87 Perl_mg_magical(pTHX_ SV *sv)
  88 {
  89     MAGIC* mg;
  90     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
  91         MGVTBL* vtbl = mg->mg_virtual;
  92         if (vtbl) {
  93             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
  94                 SvGMAGICAL_on(sv);
  95             if (vtbl->svt_set)
  96                 SvSMAGICAL_on(sv);
  97             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
  98                 SvRMAGICAL_on(sv);
  99         }
 100     }
 101 }
 102
 103 /*
 104 =for apidoc mg_get
 105
 106 Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 107
 108 =cut
 109 */
 110
 111 int
 112 Perl_mg_get(pTHX_ SV *sv)
 113 {
 114     int new = 0;
 115     MAGIC *newmg, *head, *cur, *mg;
 116     I32 mgs_ix = SSNEW(sizeof(MGS));
 117
 118     save_magic(mgs_ix, sv);
 119
 120     /* We must call svt_get(sv, mg) for each valid entry in the linked
 121        list of magic. svt_get() may delete the current entry, add new
 122        magic to the head of the list, or upgrade the SV. AMS 20010810 */
 123
 124     newmg = cur = head = mg = SvMAGIC(sv);
 125     while (mg) {
 126         MGVTBL *vtbl = mg->mg_virtual;
 127
 128         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 129             CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
 130             /* Don't restore the flags for this entry if it was deleted. */
 131             if (mg->mg_flags & MGf_GSKIP)
 132                 (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
 133         }
 134
 135         mg = mg->mg_moremagic;
 136
 137         if (new) {
 138             /* Have we finished with the new entries we saw? Start again
 139                where we left off (unless there are more new entries). */
 140             if (mg == head) {
 141                 new  = 0;
 142                 mg   = cur;
 143                 head = newmg;
 144             }
 145         }
 146
 147         /* Were any new entries added? */
 148         if (!new && (newmg = SvMAGIC(sv)) != head) {
 149             new = 1;
 150             cur = mg;
 151             mg  = newmg;
 152         }
 153     }
 154
 155     restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
 156     return 0;
 157 }
 158
 159 /*
 160 =for apidoc mg_set
 161
 162 Do magic after a value is assigned to the SV.  See C<sv_magic>.
 163
 164 =cut
 165 */
 166
 167 int
 168 Perl_mg_set(pTHX_ SV *sv)
 169 {
 170     I32 mgs_ix;
 171     MAGIC* mg;
 172     MAGIC* nextmg;
 173
 174     mgs_ix = SSNEW(sizeof(MGS));
 175     save_magic(mgs_ix, sv);
 176
 177     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 178         MGVTBL* vtbl = mg->mg_virtual;
 179         nextmg = mg->mg_moremagic;      /* it may delete itself */
 180         if (mg->mg_flags & MGf_GSKIP) {
 181             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 182             (SSPTR(mgs_ix, MGS*))->mgs_flags = 0;
 183         }
 184         if (vtbl && vtbl->svt_set)
 185             CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
 186     }
 187
 188     restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
 189     return 0;
 190 }
 191
 192 /*
 193 =for apidoc mg_length
 194
 195 Report on the SV's length.  See C<sv_magic>.
 196
 197 =cut
 198 */
 199
 200 U32
 201 Perl_mg_length(pTHX_ SV *sv)
 202 {
 203     MAGIC* mg;
 204     STRLEN len;
 205
 206     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 207         MGVTBL* vtbl = mg->mg_virtual;
 208         if (vtbl && vtbl->svt_len) {
 209             I32 mgs_ix;
 210
 211             mgs_ix = SSNEW(sizeof(MGS));
 212             save_magic(mgs_ix, sv);
 213             /* omit MGf_GSKIP -- not changed here */
 214             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 215             restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
 216             return len;
 217         }
 218     }
 219
 220     if (DO_UTF8(sv))
 221     {
 222         U8 *s = (U8*)SvPV(sv, len);
 223         len = Perl_utf8_length(aTHX_ s, s + len);
 224     }
 225     else
 226         (void)SvPV(sv, len);
 227     return len;
 228 }
 229
 230 I32
 231 Perl_mg_size(pTHX_ SV *sv)
 232 {
 233     MAGIC* mg;
 234     I32 len;
 235
 236     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 237         MGVTBL* vtbl = mg->mg_virtual;
 238         if (vtbl && vtbl->svt_len) {
 239             I32 mgs_ix;
 240
 241             mgs_ix = SSNEW(sizeof(MGS));
 242             save_magic(mgs_ix, sv);
 243             /* omit MGf_GSKIP -- not changed here */
 244             len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
 245             restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
 246             return len;
 247         }
 248     }
 249
 250     switch(SvTYPE(sv)) {
 251         case SVt_PVAV:
 252             len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
 253             return len;
 254         case SVt_PVHV:
 255             /* FIXME */
 256         default:
 257             Perl_croak(aTHX_ "Size magic not implemented");
 258             break;
 259     }
 260     return 0;
 261 }
 262
 263 /*
 264 =for apidoc mg_clear
 265
 266 Clear something magical that the SV represents.  See C<sv_magic>.
 267
 268 =cut
 269 */
 270
 271 int
 272 Perl_mg_clear(pTHX_ SV *sv)
 273 {
 274     I32 mgs_ix;
 275     MAGIC* mg;
 276
 277     mgs_ix = SSNEW(sizeof(MGS));
 278     save_magic(mgs_ix, sv);
 279
 280     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 281         MGVTBL* vtbl = mg->mg_virtual;
 282         /* omit GSKIP -- never set here */
 283
 284         if (vtbl && vtbl->svt_clear)
 285             CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
 286     }
 287
 288     restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
 289     return 0;
 290 }
 291
 292 /*
 293 =for apidoc mg_find
 294
 295 Finds the magic pointer for type matching the SV.  See C<sv_magic>.
 296
 297 =cut
 298 */
 299
 300 MAGIC*
 301 Perl_mg_find(pTHX_ SV *sv, int type)
 302 {
 303     MAGIC* mg;
 304     if (!sv)
 305         return 0;
 306     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 307         if (mg->mg_type == type)
 308             return mg;
 309     }
 310     return 0;
 311 }
 312
 313 /*
 314 =for apidoc mg_copy
 315
 316 Copies the magic from one SV to another.  See C<sv_magic>.
 317
 318 =cut
 319 */
 320
 321 int
 322 Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 323 {
 324     int count = 0;
 325     MAGIC* mg;
 326     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 327         MGVTBL* vtbl = mg->mg_virtual;
 328         if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
 329             count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
 330         }
 331         else if (isUPPER(mg->mg_type)) {
 332             sv_magic(nsv,
 333                      mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
 334                      (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
 335                                                         ? sv : mg->mg_obj,
 336                      toLOWER(mg->mg_type), key, klen);
 337             count++;
 338         }
 339     }
 340     return count;
 341 }
 342
 343 /*
 344 =for apidoc mg_free
 345
 346 Free any magic storage used by the SV.  See C<sv_magic>.
 347
 348 =cut
 349 */
 350
 351 int
 352 Perl_mg_free(pTHX_ SV *sv)
 353 {
 354     MAGIC* mg;
 355     MAGIC* moremagic;
 356     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 357         MGVTBL* vtbl = mg->mg_virtual;
 358         moremagic = mg->mg_moremagic;
 359         if (vtbl && vtbl->svt_free)
 360             CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 361         if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 362             if (mg->mg_len > 0)
 363                 Safefree(mg->mg_ptr);
 364             else if (mg->mg_len == HEf_SVKEY)
 365                 SvREFCNT_dec((SV*)mg->mg_ptr);
 366         }
 367         if (mg->mg_flags & MGf_REFCOUNTED)
 368             SvREFCNT_dec(mg->mg_obj);
 369         Safefree(mg);
 370     }
 371     SvMAGIC(sv) = 0;
 372     return 0;
 373 }
 374
 375
 376 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
 377 #include <signal.h>
 378 #endif
 379
 380 U32
 381 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
 382 {
 383     register REGEXP *rx;
 384
 385     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 386         if (mg->mg_obj)         /* @+ */
 387             return rx->nparens;
 388         else                    /* @- */
 389             return rx->lastparen;
 390     }
 391
 392     return (U32)-1;
 393 }
 394
 395 int
 396 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 397 {
 398     register I32 paren;
 399     register I32 s;
 400     register I32 i;
 401     register REGEXP *rx;
 402     I32 t;
 403
 404     if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 405         paren = mg->mg_len;
 406         if (paren < 0)
 407             return 0;
 408         if (paren <= (I32)rx->nparens &&
 409             (s = rx->startp[paren]) != -1 &&
 410             (t = rx->endp[paren]) != -1)
 411             {
 412                 if (mg->mg_obj)         /* @+ */
 413                     i = t;
 414                 else                    /* @- */
 415                     i = s;
 416
 417                 if (i > 0 && PL_reg_match_utf8) {
 418                     char *b = rx->subbeg;
 419                     if (b)
 420                         i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
 421                 }
 422
 423                 sv_setiv(sv, i);
 424             }
 425     }
 426     return 0;
 427 }
 428
 429 int
 430 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 431 {
 432     Perl_croak(aTHX_ PL_no_modify);
 433     /* NOT REACHED */
 434     return 0;
 435 }
 436
 437 U32
 438 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 439 {
 440     register I32 paren;
 441     register I32 i;
 442     register REGEXP *rx;
 443     I32 s1, t1;
 444
 445     switch (*mg->mg_ptr) {
 446     case '1': case '2': case '3': case '4':
 447     case '5': case '6': case '7': case '8': case '9': case '&':
 448         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 449
 450             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 451           getparen:
 452             if (paren <= (I32)rx->nparens &&
 453                 (s1 = rx->startp[paren]) != -1 &&
 454                 (t1 = rx->endp[paren]) != -1)
 455             {
 456                 i = t1 - s1;
 457               getlen:
 458                 if (i > 0 && PL_reg_match_utf8) {
 459                     char *s    = rx->subbeg + s1;
 460                     char *send = rx->subbeg + t1;
 461
 462                     i = t1 - s1;
 463                     if (is_utf8_string((U8*)s, i))
 464                         i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
 465                 }
 466                 if (i < 0)
 467                     Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 468                 return i;
 469             }
 470             else {
 471                 if (ckWARN(WARN_UNINITIALIZED))
 472                     report_uninit();
 473             }
 474         }
 475         else {
 476             if (ckWARN(WARN_UNINITIALIZED))
 477                 report_uninit();
 478         }
 479         return 0;
 480     case '+':
 481         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 482             paren = rx->lastparen;
 483             if (paren)
 484                 goto getparen;
 485         }
 486         return 0;
 487     case '\016': /* ^N */
 488         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 489             paren = rx->lastcloseparen;
 490             if (paren)
 491                 goto getparen;
 492         }
 493         return 0;
 494     case '`':
 495         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 496             if (rx->startp[0] != -1) {
 497                 i = rx->startp[0];
 498                 if (i > 0) {
 499                     s1 = 0;
 500                     t1 = i;
 501                     goto getlen;
 502                 }
 503             }
 504         }
 505         return 0;
 506     case '\'':
 507         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 508             if (rx->endp[0] != -1) {
 509                 i = rx->sublen - rx->endp[0];
 510                 if (i > 0) {
 511                     s1 = rx->endp[0];
 512                     t1 = rx->sublen;
 513                     goto getlen;
 514                 }
 515             }
 516         }
 517         return 0;
 518     }
 519     magic_get(sv,mg);
 520     if (!SvPOK(sv) && SvNIOK(sv)) {
 521         STRLEN n_a;
 522         sv_2pv(sv, &n_a);
 523     }
 524     if (SvPOK(sv))
 525         return SvCUR(sv);
 526     return 0;
 527 }
 528
 529 int
 530 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 531 {
 532     register I32 paren;
 533     register char *s;
 534     register I32 i;
 535     register REGEXP *rx;
 536
 537     switch (*mg->mg_ptr) {
 538     case '\001':                /* ^A */
 539         sv_setsv(sv, PL_bodytarget);
 540         break;
 541     case '\003':                /* ^C */
 542         sv_setiv(sv, (IV)PL_minus_c);
 543         break;
 544
 545     case '\004':                /* ^D */
 546         sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 547 #if defined(YYDEBUG) && defined(DEBUGGING)
 548         PL_yydebug = DEBUG_p_TEST;
 549 #endif
 550         break;
 551     case '\005':  /* ^E */
 552          if (*(mg->mg_ptr+1) == '\0') {
 553 #ifdef MACOS_TRADITIONAL
 554              {
 555                   char msg[256];
 556
 557                   sv_setnv(sv,(double)gMacPerl_OSErr);
 558                   sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 559              }
 560 #else
 561 #ifdef VMS
 562              {
 563 #                 include <descrip.h>
 564 #                 include <starlet.h>
 565                   char msg[255];
 566                   $DESCRIPTOR(msgdsc,msg);
 567                   sv_setnv(sv,(NV) vaxc$errno);
 568                   if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 569                        sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 570                   else
 571                        sv_setpv(sv,"");
 572              }
 573 #else
 574 #ifdef OS2
 575              if (!(_emx_env & 0x200)) { /* Under DOS */
 576                   sv_setnv(sv, (NV)errno);
 577                   sv_setpv(sv, errno ? Strerror(errno) : "");
 578              } else {
 579                   if (errno != errno_isOS2) {
 580                        int tmp = _syserrno();
 581                        if (tmp) /* 2nd call to _syserrno() makes it 0 */
 582                             Perl_rc = tmp;
 583                   }
 584                   sv_setnv(sv, (NV)Perl_rc);
 585                   sv_setpv(sv, os2error(Perl_rc));
 586              }
 587 #else
 588 #ifdef WIN32
 589              {
 590                   DWORD dwErr = GetLastError();
 591                   sv_setnv(sv, (NV)dwErr);
 592                   if (dwErr)
 593                   {
 594                        PerlProc_GetOSError(sv, dwErr);
 595                   }
 596                   else
 597                        sv_setpv(sv, "");
 598                   SetLastError(dwErr);
 599              }
 600 #else
 601              sv_setnv(sv, (NV)errno);
 602              sv_setpv(sv, errno ? Strerror(errno) : "");
 603 #endif
 604 #endif
 605 #endif
 606 #endif
 607              SvNOK_on(sv);      /* what a wonderful hack! */
 608          }
 609          else if (strEQ(mg->mg_ptr+1, "NCODING"))
 610               sv_setsv(sv, PL_encoding);
 611          break;
 612     case '\006':                /* ^F */
 613         sv_setiv(sv, (IV)PL_maxsysfd);
 614         break;
 615     case '\010':                /* ^H */
 616         sv_setiv(sv, (IV)PL_hints);
 617         break;
 618     case '\011':                /* ^I */ /* NOT \t in EBCDIC */
 619         if (PL_inplace)
 620             sv_setpv(sv, PL_inplace);
 621         else
 622             sv_setsv(sv, &PL_sv_undef);
 623         break;
 624     case '\017':                /* ^O & ^OPEN */
 625         if (*(mg->mg_ptr+1) == '\0')
 626             sv_setpv(sv, PL_osname);
 627         else if (strEQ(mg->mg_ptr, "\017PEN")) {
 628             if (!PL_compiling.cop_io)
 629                 sv_setsv(sv, &PL_sv_undef);
 630             else {
 631                 sv_setsv(sv, PL_compiling.cop_io);
 632             }
 633         }
 634         break;
 635     case '\020':                /* ^P */
 636         sv_setiv(sv, (IV)PL_perldb);
 637         break;
 638     case '\023':                /* ^S */
 639         {
 640             if (PL_lex_state != LEX_NOTPARSING)
 641                 (void)SvOK_off(sv);
 642             else if (PL_in_eval)
 643                 sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
 644             else
 645                 sv_setiv(sv, 0);
 646         }
 647         break;
 648     case '\024':                /* ^T */
 649         if (*(mg->mg_ptr+1) == '\0') {
 650 #ifdef BIG_TIME
 651             sv_setnv(sv, PL_basetime);
 652 #else
 653             sv_setiv(sv, (IV)PL_basetime);
 654 #endif
 655         }
 656         else if (strEQ(mg->mg_ptr, "\024AINT"))
 657             sv_setiv(sv, PL_tainting);
 658         break;
 659     case '\027':                /* ^W  & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
 660         if (*(mg->mg_ptr+1) == '\0')
 661             sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
 662         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
 663             if (PL_compiling.cop_warnings == pWARN_NONE ||
 664                 PL_compiling.cop_warnings == pWARN_STD)
 665             {
 666                 sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 667             }
 668             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 669                 sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
 670             }
 671             else {
 672                 sv_setsv(sv, PL_compiling.cop_warnings);
 673             }
 674             SvPOK_only(sv);
 675         }
 676         else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
 677             sv_setiv(sv, (IV)PL_widesyscalls);
 678         break;
 679     case '1': case '2': case '3': case '4':
 680     case '5': case '6': case '7': case '8': case '9': case '&':
 681         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 682             I32 s1, t1;
 683
 684             /*
 685              * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
 686              * XXX Does the new way break anything?
 687              */
 688             paren = atoi(mg->mg_ptr); /* $& is in [0] */
 689           getparen:
 690             if (paren <= (I32)rx->nparens &&
 691                 (s1 = rx->startp[paren]) != -1 &&
 692                 (t1 = rx->endp[paren]) != -1)
 693             {
 694                 i = t1 - s1;
 695                 s = rx->subbeg + s1;
 696                 if (!rx->subbeg)
 697                     break;
 698
 699               getrx:
 700                 if (i >= 0) {
 701                     sv_setpvn(sv, s, i);
 702                     if (PL_reg_match_utf8 && is_utf8_string((U8*)s, i))
 703                         SvUTF8_on(sv);
 704                     else
 705                         SvUTF8_off(sv);
 706                     if (PL_tainting) {
 707                         if (RX_MATCH_TAINTED(rx)) {
 708                             MAGIC* mg = SvMAGIC(sv);
 709                             MAGIC* mgt;
 710                             PL_tainted = 1;
 711                             SvMAGIC(sv) = mg->mg_moremagic;
 712                             SvTAINT(sv);
 713                             if ((mgt = SvMAGIC(sv))) {
 714                                 mg->mg_moremagic = mgt;
 715                                 SvMAGIC(sv) = mg;
 716                             }
 717                         } else
 718                             SvTAINTED_off(sv);
 719                     }
 720                     break;
 721                 }
 722             }
 723         }
 724         sv_setsv(sv,&PL_sv_undef);
 725         break;
 726     case '+':
 727         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 728             paren = rx->lastparen;
 729             if (paren)
 730                 goto getparen;
 731         }
 732         sv_setsv(sv,&PL_sv_undef);
 733         break;
 734     case '\016':                /* ^N */
 735         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 736             paren = rx->lastcloseparen;
 737             if (paren)
 738                 goto getparen;
 739         }
 740         sv_setsv(sv,&PL_sv_undef);
 741         break;
 742     case '`':
 743         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 744             if ((s = rx->subbeg) && rx->startp[0] != -1) {
 745                 i = rx->startp[0];
 746                 goto getrx;
 747             }
 748         }
 749         sv_setsv(sv,&PL_sv_undef);
 750         break;
 751     case '\'':
 752         if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
 753             if (rx->subbeg && rx->endp[0] != -1) {
 754                 s = rx->subbeg + rx->endp[0];
 755                 i = rx->sublen - rx->endp[0];
 756                 goto getrx;
 757             }
 758         }
 759         sv_setsv(sv,&PL_sv_undef);
 760         break;
 761     case '.':
 762 #ifndef lint
 763         if (GvIO(PL_last_in_gv)) {
 764             sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 765         }
 766 #endif
 767         break;
 768     case '?':
 769         {
 770             sv_setiv(sv, (IV)STATUS_CURRENT);
 771 #ifdef COMPLEX_STATUS
 772             LvTARGOFF(sv) = PL_statusvalue;
 773             LvTARGLEN(sv) = PL_statusvalue_vms;
 774 #endif
 775         }
 776         break;
 777     case '^':
 778         s = IoTOP_NAME(GvIOp(PL_defoutgv));
 779         if (s)
 780             sv_setpv(sv,s);
 781         else {
 782             sv_setpv(sv,GvENAME(PL_defoutgv));
 783             sv_catpv(sv,"_TOP");
 784         }
 785         break;
 786     case '~':
 787         s = IoFMT_NAME(GvIOp(PL_defoutgv));
 788         if (!s)
 789             s = GvENAME(PL_defoutgv);
 790         sv_setpv(sv,s);
 791         break;
 792 #ifndef lint
 793     case '=':
 794         sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
 795         break;
 796     case '-':
 797         sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
 798         break;
 799     case '%':
 800         sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
 801         break;
 802 #endif
 803     case ':':
 804         break;
 805     case '/':
 806         break;
 807     case '[':
 808         WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
 809         break;
 810     case '|':
 811         sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 812         break;
 813     case ',':
 814         break;
 815     case '\\':
 816         if (PL_ors_sv)
 817             sv_setpv(sv,SvPVX(PL_ors_sv));
 818         break;
 819     case '#':
 820         sv_setpv(sv,PL_ofmt);
 821         break;
 822     case '!':
 823 #ifdef VMS
 824         sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
 825         sv_setpv(sv, errno ? Strerror(errno) : "");
 826 #else
 827         {
 828         int saveerrno = errno;
 829         sv_setnv(sv, (NV)errno);
 830 #ifdef OS2
 831         if (errno == errno_isOS2 || errno == errno_isOS2_set)
 832             sv_setpv(sv, os2error(Perl_rc));
 833         else
 834 #endif
 835         sv_setpv(sv, errno ? Strerror(errno) : "");
 836         errno = saveerrno;
 837         }
 838 #endif
 839         SvNOK_on(sv);   /* what a wonderful hack! */
 840         break;
 841     case '<':
 842         sv_setiv(sv, (IV)PL_uid);
 843         break;
 844     case '>':
 845         sv_setiv(sv, (IV)PL_euid);
 846         break;
 847     case '(':
 848         sv_setiv(sv, (IV)PL_gid);
 849 #ifdef HAS_GETGROUPS
 850         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
 851 #endif
 852         goto add_groups;
 853     case ')':
 854         sv_setiv(sv, (IV)PL_egid);
 855 #ifdef HAS_GETGROUPS
 856         Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
 857 #endif
 858       add_groups:
 859 #ifdef HAS_GETGROUPS
 860         {
 861             Groups_t gary[NGROUPS];
 862             i = getgroups(NGROUPS,gary);
 863             while (--i >= 0)
 864                 Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
 865         }
 866 #endif
 867         (void)SvIOK_on(sv);     /* what a wonderful hack! */
 868         break;
 869     case '*':
 870         break;
 871 #ifndef MACOS_TRADITIONAL
 872     case '0':
 873         break;
 874 #endif
 875 #ifdef USE_5005THREADS
 876     case '@':
 877         sv_setsv(sv, thr->errsv);
 878         break;
 879 #endif /* USE_5005THREADS */
 880     }
 881     return 0;
 882 }
 883
 884 int
 885 Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
 886 {
 887     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
 888
 889     if (uf && uf->uf_val)
 890         (*uf->uf_val)(aTHX_ uf->uf_index, sv);
 891     return 0;
 892 }
 893
 894 int
 895 Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 896 {
 897     register char *s;
 898     char *ptr;
 899     STRLEN len, klen;
 900
 901     s = SvPV(sv,len);
 902     ptr = MgPV(mg,klen);
 903     my_setenv(ptr, s);
 904
 905 #ifdef DYNAMIC_ENV_FETCH
 906      /* We just undefd an environment var.  Is a replacement */
 907      /* waiting in the wings? */
 908     if (!len) {
 909         SV **valp;
 910         if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
 911             s = SvPV(*valp, len);
 912     }
 913 #endif
 914
 915 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
 916                             /* And you'll never guess what the dog had */
 917                             /*   in its mouth... */
 918     if (PL_tainting) {
 919         MgTAINTEDDIR_off(mg);
 920 #ifdef VMS
 921         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
 922             char pathbuf[256], eltbuf[256], *cp, *elt = s;
 923             Stat_t sbuf;
 924             int i = 0, j = 0;
 925
 926             do {          /* DCL$PATH may be a search list */
 927                 while (1) {   /* as may dev portion of any element */
 928                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
 929                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
 930                              cando_by_name(S_IWUSR,0,elt) ) {
 931                             MgTAINTEDDIR_on(mg);
 932                             return 0;
 933                         }
 934                     }
 935                     if ((cp = strchr(elt, ':')) != Nullch)
 936                         *cp = '\0';
 937                     if (my_trnlnm(elt, eltbuf, j++))
 938                         elt = eltbuf;
 939                     else
 940                         break;
 941                 }
 942                 j = 0;
 943             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
 944         }
 945 #endif /* VMS */
 946         if (s && klen == 4 && strEQ(ptr,"PATH")) {
 947             char *strend = s + len;
 948
 949             while (s < strend) {
 950                 char tmpbuf[256];
 951                 Stat_t st;
 952                 I32 i;
 953                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
 954                              s, strend, ':', &i);
 955                 s++;
 956                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
 957                       || *tmpbuf != '/'
 958                       || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
 959                     MgTAINTEDDIR_on(mg);
 960                     return 0;
 961                 }
 962             }
 963         }
 964     }
 965 #endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
 966
 967     return 0;
 968 }
 969
 970 int
 971 Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
 972 {
 973     STRLEN n_a;
 974     my_setenv(MgPV(mg,n_a),Nullch);
 975     return 0;
 976 }
 977
 978 int
 979 Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
 980 {
 981 #if defined(VMS)
 982     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
 983 #else
 984     if (PL_localizing) {
 985         HE* entry;
 986         STRLEN n_a;
 987         magic_clear_all_env(sv,mg);
 988         hv_iterinit((HV*)sv);
 989         while ((entry = hv_iternext((HV*)sv))) {
 990             I32 keylen;
 991             my_setenv(hv_iterkey(entry, &keylen),
 992                       SvPV(hv_iterval((HV*)sv, entry), n_a));
 993         }
 994     }
 995 #endif
 996     return 0;
 997 }
 998
 999 int
1000 Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
1001 {
1002 #if defined(VMS) || defined(EPOC)
1003     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
1004 #else
1005 #  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
1006     PerlEnv_clearenv();
1007 #  else
1008 #    ifdef USE_ENVIRON_ARRAY
1009 #      if defined(USE_ITHREADS)
1010     /* only the parent thread can clobber the process environment */
1011     if (PL_curinterp == aTHX)
1012 #      endif
1013     {
1014 #      ifndef PERL_USE_SAFE_PUTENV
1015     I32 i;
1016
1017     if (environ == PL_origenviron)
1018         environ = (char**)safesysmalloc(sizeof(char*));
1019     else
1020         for (i = 0; environ[i]; i++)
1021             safesysfree(environ[i]);
1022 #      endif /* PERL_USE_SAFE_PUTENV */
1023
1024     environ[0] = Nullch;
1025     }
1026 #    endif /* USE_ENVIRON_ARRAY */
1027 #   endif /* PERL_IMPLICIT_SYS || WIN32 */
1028 #endif /* VMS || EPC */
1029     return 0;
1030 }
1031
1032 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1033 static int sig_handlers_initted = 0;
1034 #endif
1035 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1036 static int sig_ignoring[SIG_SIZE];      /* which signals we are ignoring */
1037 #endif
1038 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1039 static int sig_defaulting[SIG_SIZE];
1040 #endif
1041
1042 #ifndef PERL_MICRO
1043 int
1044 Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
1045 {
1046     I32 i;
1047     STRLEN n_a;
1048     /* Are we fetching a signal entry? */
1049     i = whichsig(MgPV(mg,n_a));
1050     if (i) {
1051         if(PL_psig_ptr[i])
1052             sv_setsv(sv,PL_psig_ptr[i]);
1053         else {
1054             Sighandler_t sigstate;
1055             sigstate = rsignal_state(i);
1056 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1057             if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN;
1058 #endif
1059 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1060             if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL;
1061 #endif
1062             /* cache state so we don't fetch it again */
1063             if(sigstate == SIG_IGN)
1064                 sv_setpv(sv,"IGNORE");
1065             else
1066                 sv_setsv(sv,&PL_sv_undef);
1067             PL_psig_ptr[i] = SvREFCNT_inc(sv);
1068             SvTEMP_off(sv);
1069         }
1070     }
1071     return 0;
1072 }
1073 int
1074 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
1075 {
1076     I32 i;
1077     STRLEN n_a;
1078     /* Are we clearing a signal entry? */
1079     i = whichsig(MgPV(mg,n_a));
1080     if (i) {
1081         if(PL_psig_ptr[i]) {
1082             SvREFCNT_dec(PL_psig_ptr[i]);
1083             PL_psig_ptr[i]=0;
1084         }
1085         if(PL_psig_name[i]) {
1086             SvREFCNT_dec(PL_psig_name[i]);
1087             PL_psig_name[i]=0;
1088         }
1089     }
1090     return 0;
1091 }
1092
1093 void
1094 Perl_raise_signal(pTHX_ int sig)
1095 {
1096     /* Set a flag to say this signal is pending */
1097     PL_psig_pend[sig]++;
1098     /* And one to say _a_ signal is pending */
1099     PL_sig_pending = 1;
1100 }
1101
1102 Signal_t
1103 Perl_csighandler(int sig)
1104 {
1105 #ifdef PERL_GET_SIG_CONTEXT
1106     dTHXa(PERL_GET_SIG_CONTEXT);
1107 #else
1108     dTHX;
1109 #endif
1110 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1111     (void) rsignal(sig, &Perl_csighandler);
1112     if (sig_ignoring[sig]) return;
1113 #endif
1114 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1115     if (sig_defaulting[sig])
1116 #ifdef KILL_BY_SIGPRC
1117             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
1118 #else
1119             exit(1);
1120 #endif
1121 #endif
1122
1123 #ifdef PERL_OLD_SIGNALS
1124     /* Call the perl level handler now with risk we may be in malloc() etc. */
1125     (*PL_sighandlerp)(sig);
1126 #else
1127     Perl_raise_signal(aTHX_ sig);
1128 #endif
1129 }
1130
1131 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1132 void
1133 Perl_csighandler_init(void)
1134 {
1135     int sig;
1136     if (sig_handlers_initted) return;
1137
1138     for (sig = 1; sig < SIG_SIZE; sig++) {
1139 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1140         dTHX;
1141         sig_defaulting[sig] = 1;
1142         (void) rsignal(sig, &Perl_csighandler);
1143 #endif
1144 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1145         sig_ignoring[sig] = 0;
1146 #endif
1147     }
1148     sig_handlers_initted = 1;
1149 }
1150 #endif
1151
1152 void
1153 Perl_despatch_signals(pTHX)
1154 {
1155     int sig;
1156     PL_sig_pending = 0;
1157     for (sig = 1; sig < SIG_SIZE; sig++) {
1158         if (PL_psig_pend[sig]) {
1159             PL_psig_pend[sig] = 0;
1160             (*PL_sighandlerp)(sig);
1161         }
1162     }
1163 }
1164
1165 int
1166 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
1167 {
1168     register char *s;
1169     I32 i;
1170     SV** svp = 0;
1171     STRLEN len;
1172
1173     s = MgPV(mg,len);
1174     if (*s == '_') {
1175         if (strEQ(s,"__DIE__"))
1176             svp = &PL_diehook;
1177         else if (strEQ(s,"__WARN__"))
1178             svp = &PL_warnhook;
1179         else
1180             Perl_croak(aTHX_ "No such hook: %s", s);
1181         i = 0;
1182         if (*svp) {
1183             SvREFCNT_dec(*svp);
1184             *svp = 0;
1185         }
1186     }
1187     else {
1188         i = whichsig(s);        /* ...no, a brick */
1189         if (!i) {
1190             if (ckWARN(WARN_SIGNAL))
1191                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
1192             return 0;
1193         }
1194 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
1195         if (!sig_handlers_initted) Perl_csighandler_init();
1196 #endif
1197 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1198         sig_ignoring[i] = 0;
1199 #endif
1200 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1201           sig_defaulting[i] = 0;
1202 #endif
1203         SvREFCNT_dec(PL_psig_name[i]);
1204         SvREFCNT_dec(PL_psig_ptr[i]);
1205         PL_psig_ptr[i] = SvREFCNT_inc(sv);
1206         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
1207         PL_psig_name[i] = newSVpvn(s, len);
1208         SvREADONLY_on(PL_psig_name[i]);
1209     }
1210     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
1211         if (i)
1212             (void)rsignal(i, &Perl_csighandler);
1213         else
1214             *svp = SvREFCNT_inc(sv);
1215         return 0;
1216     }
1217     s = SvPV_force(sv,len);
1218     if (strEQ(s,"IGNORE")) {
1219         if (i) {
1220 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
1221             sig_ignoring[i] = 1;
1222             (void)rsignal(i, &Perl_csighandler);
1223 #else
1224             (void)rsignal(i, SIG_IGN);
1225 #endif
1226         } else
1227             *svp = 0;
1228     }
1229     else if (strEQ(s,"DEFAULT") || !*s) {
1230         if (i)
1231 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
1232           {
1233             sig_defaulting[i] = 1;
1234             (void)rsignal(i, &Perl_csighandler);
1235           }
1236 #else
1237             (void)rsignal(i, SIG_DFL);
1238 #endif
1239         else
1240             *svp = 0;
1241     }
1242     else {
1243         /*
1244          * We should warn if HINT_STRICT_REFS, but without
1245          * access to a known hint bit in a known OP, we can't
1246          * tell whether HINT_STRICT_REFS is in force or not.
1247          */
1248         if (!strchr(s,':') && !strchr(s,'\''))
1249             sv_insert(sv, 0, 0, "main::", 6);
1250         if (i)
1251             (void)rsignal(i, &Perl_csighandler);
1252         else
1253             *svp = SvREFCNT_inc(sv);
1254     }
1255     return 0;
1256 }
1257 #endif /* !PERL_MICRO */
1258
1259 int
1260 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
1261 {
1262     PL_sub_generation++;
1263     return 0;
1264 }
1265
1266 int
1267 Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
1268 {
1269     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
1270     PL_amagic_generation++;
1271
1272     return 0;
1273 }
1274
1275 int
1276 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
1277 {
1278     HV *hv = (HV*)LvTARG(sv);
1279     I32 i = 0;
1280
1281     if (hv) {
1282          (void) hv_iterinit(hv);
1283          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
1284              i = HvKEYS(hv);
1285          else {
1286              while (hv_iternext(hv))
1287                  i++;
1288          }
1289     }
1290
1291     sv_setiv(sv, (IV)i);
1292     return 0;
1293 }
1294
1295 int
1296 Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
1297 {
1298     if (LvTARG(sv)) {
1299         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
1300     }
1301     return 0;
1302 }
1303
1304 /* caller is responsible for stack switching/cleanup */
1305 STATIC int
1306 S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
1307 {
1308     dSP;
1309
1310     PUSHMARK(SP);
1311     EXTEND(SP, n);
1312     PUSHs(SvTIED_obj(sv, mg));
1313     if (n > 1) {
1314         if (mg->mg_ptr) {
1315             if (mg->mg_len >= 0)
1316                 PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
1317             else if (mg->mg_len == HEf_SVKEY)
1318                 PUSHs((SV*)mg->mg_ptr);
1319         }
1320         else if (mg->mg_type == PERL_MAGIC_tiedelem) {
1321             PUSHs(sv_2mortal(newSViv(mg->mg_len)));
1322         }
1323     }
1324     if (n > 2) {
1325         PUSHs(val);
1326     }
1327     PUTBACK;
1328
1329     return call_method(meth, flags);
1330 }
1331
1332 STATIC int
1333 S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
1334 {
1335     dSP;
1336
1337     ENTER;
1338     SAVETMPS;
1339     PUSHSTACKi(PERLSI_MAGIC);
1340
1341     if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
1342         sv_setsv(sv, *PL_stack_sp--);
1343     }
1344
1345     POPSTACK;
1346     FREETMPS;
1347     LEAVE;
1348     return 0;
1349 }
1350
1351 int
1352 Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
1353 {
1354     magic_methpack(sv,mg,"FETCH");
1355     if (mg->mg_ptr)
1356         mg->mg_flags |= MGf_GSKIP;
1357     return 0;
1358 }
1359
1360 int
1361 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
1362 {
1363     dSP;
1364     ENTER;
1365     PUSHSTACKi(PERLSI_MAGIC);
1366     magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
1367     POPSTACK;
1368     LEAVE;
1369     return 0;
1370 }
1371
1372 int
1373 Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
1374 {
1375     return magic_methpack(sv,mg,"DELETE");
1376 }
1377
1378
1379 U32
1380 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
1381 {
1382     dSP;
1383     U32 retval = 0;
1384
1385     ENTER;
1386     SAVETMPS;
1387     PUSHSTACKi(PERLSI_MAGIC);
1388     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
1389         sv = *PL_stack_sp--;
1390         retval = (U32) SvIV(sv)-1;
1391     }
1392     POPSTACK;
1393     FREETMPS;
1394     LEAVE;
1395     return retval;
1396 }
1397
1398 int
1399 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
1400 {
1401     dSP;
1402
1403     ENTER;
1404     PUSHSTACKi(PERLSI_MAGIC);
1405     PUSHMARK(SP);
1406     XPUSHs(SvTIED_obj(sv, mg));
1407     PUTBACK;
1408     call_method("CLEAR", G_SCALAR|G_DISCARD);
1409     POPSTACK;
1410     LEAVE;
1411     return 0;
1412 }
1413
1414 int
1415 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
1416 {
1417     dSP;
1418     const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
1419
1420     ENTER;
1421     SAVETMPS;
1422     PUSHSTACKi(PERLSI_MAGIC);
1423     PUSHMARK(SP);
1424     EXTEND(SP, 2);
1425     PUSHs(SvTIED_obj(sv, mg));
1426     if (SvOK(key))
1427         PUSHs(key);
1428     PUTBACK;
1429
1430     if (call_method(meth, G_SCALAR))
1431         sv_setsv(key, *PL_stack_sp--);
1432
1433     POPSTACK;
1434     FREETMPS;
1435     LEAVE;
1436     return 0;
1437 }
1438
1439 int
1440 Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
1441 {
1442     return magic_methpack(sv,mg,"EXISTS");
1443 }
1444
1445 int
1446 Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
1447 {
1448     OP *o;
1449     I32 i;
1450     GV* gv;
1451     SV** svp;
1452     STRLEN n_a;
1453
1454     gv = PL_DBline;
1455     i = SvTRUE(sv);
1456     svp = av_fetch(GvAV(gv),
1457                      atoi(MgPV(mg,n_a)), FALSE);
1458     if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp))))
1459         o->op_private = (U8)i;
1460     return 0;
1461 }
1462
1463 int
1464 Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
1465 {
1466     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
1467     return 0;
1468 }
1469
1470 int
1471 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
1472 {
1473     av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
1474     return 0;
1475 }
1476
1477 int
1478 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
1479 {
1480     SV* lsv = LvTARG(sv);
1481
1482     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1483         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1484         if (mg && mg->mg_len >= 0) {
1485             I32 i = mg->mg_len;
1486             if (DO_UTF8(lsv))
1487                 sv_pos_b2u(lsv, &i);
1488             sv_setiv(sv, i + PL_curcop->cop_arybase);
1489             return 0;
1490         }
1491     }
1492     (void)SvOK_off(sv);
1493     return 0;
1494 }
1495
1496 int
1497 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
1498 {
1499     SV* lsv = LvTARG(sv);
1500     SSize_t pos;
1501     STRLEN len;
1502     STRLEN ulen = 0;
1503
1504     mg = 0;
1505
1506     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1507         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1508     if (!mg) {
1509         if (!SvOK(sv))
1510             return 0;
1511         sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1512         mg = mg_find(lsv, PERL_MAGIC_regex_global);
1513     }
1514     else if (!SvOK(sv)) {
1515         mg->mg_len = -1;
1516         return 0;
1517     }
1518     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1519
1520     pos = SvIV(sv) - PL_curcop->cop_arybase;
1521
1522     if (DO_UTF8(lsv)) {
1523         ulen = sv_len_utf8(lsv);
1524         if (ulen)
1525             len = ulen;
1526     }
1527
1528     if (pos < 0) {
1529         pos += len;
1530         if (pos < 0)
1531             pos = 0;
1532     }
1533     else if (pos > (SSize_t)len)
1534         pos = len;
1535
1536     if (ulen) {
1537         I32 p = pos;
1538         sv_pos_u2b(lsv, &p, 0);
1539         pos = p;
1540     }
1541
1542     mg->mg_len = pos;
1543     mg->mg_flags &= ~MGf_MINMATCH;
1544
1545     return 0;
1546 }
1547
1548 int
1549 Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
1550 {
1551     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1552         SvFAKE_off(sv);
1553         gv_efullname3(sv,((GV*)sv), "*");
1554         SvFAKE_on(sv);
1555     }
1556     else
1557         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1558     return 0;
1559 }
1560
1561 int
1562 Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
1563 {
1564     register char *s;
1565     GV* gv;
1566     STRLEN n_a;
1567
1568     if (!SvOK(sv))
1569         return 0;
1570     s = SvPV(sv, n_a);
1571     if (*s == '*' && s[1])
1572         s++;
1573     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1574     if (sv == (SV*)gv)
1575         return 0;
1576     if (GvGP(sv))
1577         gp_free((GV*)sv);
1578     GvGP(sv) = gp_ref(GvGP(gv));
1579     return 0;
1580 }
1581
1582 int
1583 Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
1584 {
1585     STRLEN len;
1586     SV *lsv = LvTARG(sv);
1587     char *tmps = SvPV(lsv,len);
1588     I32 offs = LvTARGOFF(sv);
1589     I32 rem = LvTARGLEN(sv);
1590
1591     if (SvUTF8(lsv))
1592         sv_pos_u2b(lsv, &offs, &rem);
1593     if (offs > (I32)len)
1594         offs = len;
1595     if (rem + offs > (I32)len)
1596         rem = len - offs;
1597     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
1598     if (SvUTF8(lsv))
1599         SvUTF8_on(sv);
1600     return 0;
1601 }
1602
1603 int
1604 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
1605 {
1606     STRLEN len;
1607     char *tmps = SvPV(sv, len);
1608     SV *lsv = LvTARG(sv);
1609     I32 lvoff = LvTARGOFF(sv);
1610     I32 lvlen = LvTARGLEN(sv);
1611
1612     if (DO_UTF8(sv)) {
1613         sv_utf8_upgrade(lsv);
1614         sv_pos_u2b(lsv, &lvoff, &lvlen);
1615         sv_insert(lsv, lvoff, lvlen, tmps, len);
1616         SvUTF8_on(lsv);
1617     }
1618     else if (lsv && SvUTF8(lsv)) {
1619         sv_pos_u2b(lsv, &lvoff, &lvlen);
1620         tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
1621         sv_insert(lsv, lvoff, lvlen, tmps, len);
1622         Safefree(tmps);
1623     }
1624     else
1625         sv_insert(lsv, lvoff, lvlen, tmps, len);
1626
1627     return 0;
1628 }
1629
1630 int
1631 Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
1632 {
1633     TAINT_IF((mg->mg_len & 1) ||
1634              ((mg->mg_len & 2) && mg->mg_obj == sv));   /* kludge */
1635     return 0;
1636 }
1637
1638 int
1639 Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
1640 {
1641     if (PL_localizing) {
1642         if (PL_localizing == 1)
1643             mg->mg_len <<= 1;
1644         else
1645             mg->mg_len >>= 1;
1646     }
1647     else if (PL_tainted)
1648         mg->mg_len |= 1;
1649     else
1650         mg->mg_len &= ~1;
1651     return 0;
1652 }
1653
1654 int
1655 Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
1656 {
1657     SV *lsv = LvTARG(sv);
1658
1659     if (!lsv) {
1660         (void)SvOK_off(sv);
1661         return 0;
1662     }
1663
1664     sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
1665     return 0;
1666 }
1667
1668 int
1669 Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
1670 {
1671     do_vecset(sv);      /* XXX slurp this routine */
1672     return 0;
1673 }
1674
1675 int
1676 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
1677 {
1678     SV *targ = Nullsv;
1679     if (LvTARGLEN(sv)) {
1680         if (mg->mg_obj) {
1681             SV *ahv = LvTARG(sv);
1682             HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
1683             if (he)
1684                 targ = HeVAL(he);
1685         }
1686         else {
1687             AV* av = (AV*)LvTARG(sv);
1688             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1689                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1690         }
1691         if (targ && targ != &PL_sv_undef) {
1692             /* somebody else defined it for us */
1693             SvREFCNT_dec(LvTARG(sv));
1694             LvTARG(sv) = SvREFCNT_inc(targ);
1695             LvTARGLEN(sv) = 0;
1696             SvREFCNT_dec(mg->mg_obj);
1697             mg->mg_obj = Nullsv;
1698             mg->mg_flags &= ~MGf_REFCOUNTED;
1699         }
1700     }
1701     else
1702         targ = LvTARG(sv);
1703     sv_setsv(sv, targ ? targ : &PL_sv_undef);
1704     return 0;
1705 }
1706
1707 int
1708 Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
1709 {
1710     if (LvTARGLEN(sv))
1711         vivify_defelem(sv);
1712     if (LvTARG(sv)) {
1713         sv_setsv(LvTARG(sv), sv);
1714         SvSETMAGIC(LvTARG(sv));
1715     }
1716     return 0;
1717 }
1718
1719 void
1720 Perl_vivify_defelem(pTHX_ SV *sv)
1721 {
1722     MAGIC *mg;
1723     SV *value = Nullsv;
1724
1725     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
1726         return;
1727     if (mg->mg_obj) {
1728         SV *ahv = LvTARG(sv);
1729         STRLEN n_a;
1730         HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
1731         if (he)
1732             value = HeVAL(he);
1733         if (!value || value == &PL_sv_undef)
1734             Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
1735     }
1736     else {
1737         AV* av = (AV*)LvTARG(sv);
1738         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1739             LvTARG(sv) = Nullsv;        /* array can't be extended */
1740         else {
1741             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1742             if (!svp || (value = *svp) == &PL_sv_undef)
1743                 Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
1744         }
1745     }
1746     (void)SvREFCNT_inc(value);
1747     SvREFCNT_dec(LvTARG(sv));
1748     LvTARG(sv) = value;
1749     LvTARGLEN(sv) = 0;
1750     SvREFCNT_dec(mg->mg_obj);
1751     mg->mg_obj = Nullsv;
1752     mg->mg_flags &= ~MGf_REFCOUNTED;
1753 }
1754
1755 int
1756 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
1757 {
1758     AV *av = (AV*)mg->mg_obj;
1759     SV **svp = AvARRAY(av);
1760     I32 i = AvFILLp(av);
1761     while (i >= 0) {
1762         if (svp[i] && svp[i] != &PL_sv_undef) {
1763             if (!SvWEAKREF(svp[i]))
1764                 Perl_croak(aTHX_ "panic: magic_killbackrefs");
1765             /* XXX Should we check that it hasn't changed? */
1766             SvRV(svp[i]) = 0;
1767             (void)SvOK_off(svp[i]);
1768             SvWEAKREF_off(svp[i]);
1769             svp[i] = &PL_sv_undef;
1770         }
1771         i--;
1772     }
1773     return 0;
1774 }
1775
1776 int
1777 Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
1778 {
1779     mg->mg_len = -1;
1780     SvSCREAM_off(sv);
1781     return 0;
1782 }
1783
1784 int
1785 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
1786 {
1787     sv_unmagic(sv, PERL_MAGIC_bm);
1788     SvVALID_off(sv);
1789     return 0;
1790 }
1791
1792 int
1793 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
1794 {
1795     sv_unmagic(sv, PERL_MAGIC_fm);
1796     SvCOMPILED_off(sv);
1797     return 0;
1798 }
1799
1800 int
1801 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
1802 {
1803     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1804
1805     if (uf && uf->uf_set)
1806         (*uf->uf_set)(aTHX_ uf->uf_index, sv);
1807     return 0;
1808 }
1809
1810 int
1811 Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
1812 {
1813     regexp *re = (regexp *)mg->mg_obj;
1814     ReREFCNT_dec(re);
1815     return 0;
1816 }
1817
1818 #ifdef USE_LOCALE_COLLATE
1819 int
1820 Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
1821 {
1822     /*
1823      * RenE<eacute> Descartes said "I think not."
1824      * and vanished with a faint plop.
1825      */
1826     if (mg->mg_ptr) {
1827         Safefree(mg->mg_ptr);
1828         mg->mg_ptr = NULL;
1829         mg->mg_len = -1;
1830     }
1831     return 0;
1832 }
1833 #endif /* USE_LOCALE_COLLATE */
1834
1835 int
1836 Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
1837 {
1838     register char *s;
1839     I32 i;
1840     STRLEN len;
1841     switch (*mg->mg_ptr) {
1842     case '\001':        /* ^A */
1843         sv_setsv(PL_bodytarget, sv);
1844         break;
1845     case '\003':        /* ^C */
1846         PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1847         break;
1848
1849     case '\004':        /* ^D */
1850         PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
1851         DEBUG_x(dump_all());
1852         break;
1853     case '\005':  /* ^E */
1854          if (*(mg->mg_ptr+1) == '\0') {
1855 #ifdef MACOS_TRADITIONAL
1856               gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1857 #else
1858 #  ifdef VMS
1859               set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1860 #  else
1861 #    ifdef WIN32
1862               SetLastError( SvIV(sv) );
1863 #    else
1864 #      ifdef OS2
1865               os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1866 #      else
1867               /* will anyone ever use this? */
1868               SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
1869 #      endif
1870 #    endif
1871 #  endif
1872 #endif
1873          }
1874          else if (strEQ(mg->mg_ptr+1, "NCODING")) {
1875              if (PL_encoding)
1876                  sv_setsv(PL_encoding, sv);
1877              else
1878                  PL_encoding = newSVsv(sv);
1879          }
1880     case '\006':        /* ^F */
1881         PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1882         break;
1883     case '\010':        /* ^H */
1884         PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1885         break;
1886     case '\011':        /* ^I */ /* NOT \t in EBCDIC */
1887         if (PL_inplace)
1888             Safefree(PL_inplace);
1889         if (SvOK(sv))
1890             PL_inplace = savepv(SvPV(sv,len));
1891         else
1892             PL_inplace = Nullch;
1893         break;
1894     case '\017':        /* ^O */
1895         if (*(mg->mg_ptr+1) == '\0') {
1896             if (PL_osname)
1897                 Safefree(PL_osname);
1898             if (SvOK(sv))
1899                 PL_osname = savepv(SvPV(sv,len));
1900             else
1901                 PL_osname = Nullch;
1902         }
1903         else if (strEQ(mg->mg_ptr, "\017PEN")) {
1904             if (!PL_compiling.cop_io)
1905                 PL_compiling.cop_io = newSVsv(sv);
1906             else
1907                 sv_setsv(PL_compiling.cop_io,sv);
1908         }
1909         break;
1910     case '\020':        /* ^P */
1911         PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1912         if (PL_perldb && !PL_DBsingle)
1913             init_debugger();
1914         break;
1915     case '\024':        /* ^T */
1916 #ifdef BIG_TIME
1917         PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1918 #else
1919         PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1920 #endif
1921         break;
1922     case '\027':        /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */
1923         if (*(mg->mg_ptr+1) == '\0') {
1924             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1925                 i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1926                 PL_dowarn = (PL_dowarn & ~G_WARN_ON)
1927                                 | (i ? G_WARN_ON : G_WARN_OFF) ;
1928             }
1929         }
1930         else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
1931             if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
1932                 if (!SvPOK(sv) && PL_localizing) {
1933                     sv_setpvn(sv, WARN_NONEstring, WARNsize);
1934                     PL_compiling.cop_warnings = pWARN_NONE;
1935                     break;
1936                 }
1937                 {
1938                     STRLEN len, i;
1939                     int accumulate = 0 ;
1940                     int any_fatals = 0 ;
1941                     char * ptr = (char*)SvPV(sv, len) ;
1942                     for (i = 0 ; i < len ; ++i) {
1943                         accumulate |= ptr[i] ;
1944                         any_fatals |= (ptr[i] & 0xAA) ;
1945                     }
1946                     if (!accumulate)
1947                         PL_compiling.cop_warnings = pWARN_NONE;
1948                     else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
1949                         PL_compiling.cop_warnings = pWARN_ALL;
1950                         PL_dowarn |= G_WARN_ONCE ;
1951                     }
1952                     else {
1953                         if (specialWARN(PL_compiling.cop_warnings))
1954                             PL_compiling.cop_warnings = newSVsv(sv) ;
1955                         else
1956                             sv_setsv(PL_compiling.cop_warnings, sv);
1957                         if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
1958                             PL_dowarn |= G_WARN_ONCE ;
1959                     }
1960
1961                 }
1962             }
1963         }
1964         else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
1965             PL_widesyscalls = (bool)SvTRUE(sv);
1966         break;
1967     case '.':
1968         if (PL_localizing) {
1969             if (PL_localizing == 1)
1970                 SAVESPTR(PL_last_in_gv);
1971         }
1972         else if (SvOK(sv) && GvIO(PL_last_in_gv))
1973             IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
1974         break;
1975     case '^':
1976         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
1977         IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1978         IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1979         break;
1980     case '~':
1981         Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
1982         IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
1983         IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1984         break;
1985     case '=':
1986         IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1987         break;
1988     case '-':
1989         IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1990         if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
1991             IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
1992         break;
1993     case '%':
1994         IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1995         break;
1996     case '|':
1997         {
1998             IO *io = GvIOp(PL_defoutgv);
1999             if(!io)
2000               break;
2001             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
2002                 IoFLAGS(io) &= ~IOf_FLUSH;
2003             else {
2004                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
2005                     PerlIO *ofp = IoOFP(io);
2006                     if (ofp)
2007                         (void)PerlIO_flush(ofp);
2008                     IoFLAGS(io) |= IOf_FLUSH;
2009                 }
2010             }
2011         }
2012         break;
2013     case '*':
2014         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2015         PL_multiline = (i != 0);
2016         break;
2017     case '/':
2018         SvREFCNT_dec(PL_rs);
2019         PL_rs = newSVsv(sv);
2020         break;
2021     case '\\':
2022         if (PL_ors_sv)
2023             SvREFCNT_dec(PL_ors_sv);
2024         if (SvOK(sv) || SvGMAGICAL(sv)) {
2025             PL_ors_sv = newSVsv(sv);
2026         }
2027         else {
2028             PL_ors_sv = Nullsv;
2029         }
2030         break;
2031     case ',':
2032         if (PL_ofs_sv)
2033             SvREFCNT_dec(PL_ofs_sv);
2034         if (SvOK(sv) || SvGMAGICAL(sv)) {
2035             PL_ofs_sv = newSVsv(sv);
2036         }
2037         else {
2038             PL_ofs_sv = Nullsv;
2039         }
2040         break;
2041     case '#':
2042         if (PL_ofmt)
2043             Safefree(PL_ofmt);
2044         PL_ofmt = savepv(SvPV(sv,len));
2045         break;
2046     case '[':
2047         PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2048         break;
2049     case '?':
2050 #ifdef COMPLEX_STATUS
2051         if (PL_localizing == 2) {
2052             PL_statusvalue = LvTARGOFF(sv);
2053             PL_statusvalue_vms = LvTARGLEN(sv);
2054         }
2055         else
2056 #endif
2057 #ifdef VMSISH_STATUS
2058         if (VMSISH_STATUS)
2059             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
2060         else
2061 #endif
2062             STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
2063         break;
2064     case '!':
2065         {
2066 #ifdef VMS
2067 #   define PERL_VMS_BANG vaxc$errno
2068 #else
2069 #   define PERL_VMS_BANG 0
2070 #endif
2071         SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0,
2072                  (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG);
2073         }
2074         break;
2075     case '<':
2076         PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2077         if (PL_delaymagic) {
2078             PL_delaymagic |= DM_RUID;
2079             break;                              /* don't do magic till later */
2080         }
2081 #ifdef HAS_SETRUID
2082         (void)setruid((Uid_t)PL_uid);
2083 #else
2084 #ifdef HAS_SETREUID
2085         (void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
2086 #else
2087 #ifdef HAS_SETRESUID
2088       (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
2089 #else
2090         if (PL_uid == PL_euid)          /* special case $< = $> */
2091             (void)PerlProc_setuid(PL_uid);
2092         else {
2093             PL_uid = PerlProc_getuid();
2094             Perl_croak(aTHX_ "setruid() not implemented");
2095         }
2096 #endif
2097 #endif
2098 #endif
2099         PL_uid = PerlProc_getuid();
2100         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2101         break;
2102     case '>':
2103         PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2104         if (PL_delaymagic) {
2105             PL_delaymagic |= DM_EUID;
2106             break;                              /* don't do magic till later */
2107         }
2108 #ifdef HAS_SETEUID
2109         (void)seteuid((Uid_t)PL_euid);
2110 #else
2111 #ifdef HAS_SETREUID
2112         (void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
2113 #else
2114 #ifdef HAS_SETRESUID
2115         (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
2116 #else
2117         if (PL_euid == PL_uid)          /* special case $> = $< */
2118             PerlProc_setuid(PL_euid);
2119         else {
2120             PL_euid = PerlProc_geteuid();
2121             Perl_croak(aTHX_ "seteuid() not implemented");
2122         }
2123 #endif
2124 #endif
2125 #endif
2126         PL_euid = PerlProc_geteuid();
2127         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2128         break;
2129     case '(':
2130         PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2131         if (PL_delaymagic) {
2132             PL_delaymagic |= DM_RGID;
2133             break;                              /* don't do magic till later */
2134         }
2135 #ifdef HAS_SETRGID
2136         (void)setrgid((Gid_t)PL_gid);
2137 #else
2138 #ifdef HAS_SETREGID
2139         (void)setregid((Gid_t)PL_gid, (Gid_t)-1);
2140 #else
2141 #ifdef HAS_SETRESGID
2142       (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
2143 #else
2144         if (PL_gid == PL_egid)                  /* special case $( = $) */
2145             (void)PerlProc_setgid(PL_gid);
2146         else {
2147             PL_gid = PerlProc_getgid();
2148             Perl_croak(aTHX_ "setrgid() not implemented");
2149         }
2150 #endif
2151 #endif
2152 #endif
2153         PL_gid = PerlProc_getgid();
2154         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2155         break;
2156     case ')':
2157 #ifdef HAS_SETGROUPS
2158         {
2159             char *p = SvPV(sv, len);
2160             Groups_t gary[NGROUPS];
2161
2162             while (isSPACE(*p))
2163                 ++p;
2164             PL_egid = Atol(p);
2165             for (i = 0; i < NGROUPS; ++i) {
2166                 while (*p && !isSPACE(*p))
2167                     ++p;
2168                 while (isSPACE(*p))
2169                     ++p;
2170                 if (!*p)
2171                     break;
2172                 gary[i] = Atol(p);
2173             }
2174             if (i)
2175                 (void)setgroups(i, gary);
2176         }
2177 #else  /* HAS_SETGROUPS */
2178         PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
2179 #endif /* HAS_SETGROUPS */
2180         if (PL_delaymagic) {
2181             PL_delaymagic |= DM_EGID;
2182             break;                              /* don't do magic till later */
2183         }
2184 #ifdef HAS_SETEGID
2185         (void)setegid((Gid_t)PL_egid);
2186 #else
2187 #ifdef HAS_SETREGID
2188         (void)setregid((Gid_t)-1, (Gid_t)PL_egid);
2189 #else
2190 #ifdef HAS_SETRESGID
2191         (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
2192 #else
2193         if (PL_egid == PL_gid)                  /* special case $) = $( */
2194             (void)PerlProc_setgid(PL_egid);
2195         else {
2196             PL_egid = PerlProc_getegid();
2197             Perl_croak(aTHX_ "setegid() not implemented");
2198         }
2199 #endif
2200 #endif
2201 #endif
2202         PL_egid = PerlProc_getegid();
2203         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2204         break;
2205     case ':':
2206         PL_chopset = SvPV_force(sv,len);
2207         break;
2208 #ifndef MACOS_TRADITIONAL
2209     case '0':
2210 #ifdef HAS_SETPROCTITLE
2211         /* The BSDs don't show the argv[] in ps(1) output, they
2212          * show a string from the process struct and provide
2213          * the setproctitle() routine to manipulate that. */
2214         {
2215             s = SvPV(sv, len);
2216 #   if __FreeBSD_version > 410001
2217             /* The leading "-" removes the "perl: " prefix,
2218              * but not the "(perl) suffix from the ps(1)
2219              * output, because that's what ps(1) shows if the
2220              * argv[] is modified. */
2221             setproctitle("-%s", s);
2222 #   else        /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */
2223             /* This doesn't really work if you assume that
2224              * $0 = 'foobar'; will wipe out 'perl' from the $0
2225              * because in ps(1) output the result will be like
2226              * sprintf("perl: %s (perl)", s)
2227              * I guess this is a security feature:
2228              * one (a user process) cannot get rid of the original name.
2229              * --jhi */
2230             setproctitle("%s", s);
2231 #   endif
2232         }
2233 #endif
2234         if (!PL_origalen) {
2235             s = PL_origargv[0];
2236             s += strlen(s);
2237             /* See if all the arguments are contiguous in memory */
2238             for (i = 1; i < PL_origargc; i++) {
2239                 if (PL_origargv[i] == s + 1
2240 #ifdef OS2
2241                     || PL_origargv[i] == s + 2
2242 #endif
2243                    )
2244                 {
2245                     ++s;
2246                     s += strlen(s);     /* this one is ok too */
2247                 }
2248                 else
2249                     break;
2250             }
2251             /* can grab env area too? */
2252             if (PL_origenviron
2253 #ifdef USE_ITHREADS
2254                 && PL_curinterp == aTHX
2255 #endif
2256                 && (PL_origenviron[0] == s + 1))
2257             {
2258                 my_setenv("NoNe  SuCh", Nullch);
2259                                             /* force copy of environment */
2260                 for (i = 0; PL_origenviron[i]; i++)
2261                     if (PL_origenviron[i] == s + 1) {
2262                         ++s;
2263                         s += strlen(s);
2264                     }
2265                     else
2266                         break;
2267             }
2268             PL_origalen = s - PL_origargv[0];
2269         }
2270         s = SvPV_force(sv,len);
2271         i = len;
2272         if (i >= (I32)PL_origalen) {
2273             i = PL_origalen;
2274             /* don't allow system to limit $0 seen by script */
2275             /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
2276             Copy(s, PL_origargv[0], i, char);
2277             s = PL_origargv[0]+i;
2278             *s = '\0';
2279         }
2280         else {
2281             Copy(s, PL_origargv[0], i, char);
2282             s = PL_origargv[0]+i;
2283             *s++ = '\0';
2284             while (++i < (I32)PL_origalen)
2285                 *s++ = '\0';
2286             for (i = 1; i < PL_origargc; i++)
2287                 PL_origargv[i] = Nullch;
2288         }
2289         break;
2290 #endif
2291 #ifdef USE_5005THREADS
2292     case '@':
2293         sv_setsv(thr->errsv, sv);
2294         break;
2295 #endif /* USE_5005THREADS */
2296     }
2297     return 0;
2298 }
2299
2300 #ifdef USE_5005THREADS
2301 int
2302 Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg)
2303 {
2304     DEBUG_S(PerlIO_printf(Perl_debug_log,
2305                           "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n",
2306                           PTR2UV(thr), PTR2UV(sv)));
2307     if (MgOWNER(mg))
2308         Perl_croak(aTHX_ "panic: magic_mutexfree");
2309     MUTEX_DESTROY(MgMUTEXP(mg));
2310     COND_DESTROY(MgCONDP(mg));
2311     return 0;
2312 }
2313 #endif /* USE_5005THREADS */
2314
2315 I32
2316 Perl_whichsig(pTHX_ char *sig)
2317 {
2318     register char **sigv;
2319
2320     for (sigv = PL_sig_name+1; *sigv; sigv++)
2321         if (strEQ(sig,*sigv))
2322             return PL_sig_num[sigv - PL_sig_name];
2323 #ifdef SIGCLD
2324     if (strEQ(sig,"CHLD"))
2325         return SIGCLD;
2326 #endif
2327 #ifdef SIGCHLD
2328     if (strEQ(sig,"CLD"))
2329         return SIGCHLD;
2330 #endif
2331     return 0;
2332 }
2333
2334 #if !defined(PERL_IMPLICIT_CONTEXT)
2335 static SV* sig_sv;
2336 #endif
2337
2338 Signal_t
2339 Perl_sighandler(int sig)
2340 {
2341 #ifdef PERL_GET_SIG_CONTEXT
2342     dTHXa(PERL_GET_SIG_CONTEXT);
2343 #else
2344     dTHX;
2345 #endif
2346     dSP;
2347     GV *gv = Nullgv;
2348     HV *st;
2349     SV *sv = Nullsv, *tSv = PL_Sv;
2350     CV *cv = Nullcv;
2351     OP *myop = PL_op;
2352     U32 flags = 0;
2353     XPV *tXpv = PL_Xpv;
2354
2355     if (PL_savestack_ix + 15 <= PL_savestack_max)
2356         flags |= 1;
2357     if (PL_markstack_ptr < PL_markstack_max - 2)
2358         flags |= 4;
2359     if (PL_retstack_ix < PL_retstack_max - 2)
2360         flags |= 8;
2361     if (PL_scopestack_ix < PL_scopestack_max - 3)
2362         flags |= 16;
2363
2364     if (!PL_psig_ptr[sig]) {
2365                 PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
2366                                  PL_sig_name[sig]);
2367                 exit(sig);
2368         }
2369
2370     /* Max number of items pushed there is 3*n or 4. We cannot fix
2371        infinity, so we fix 4 (in fact 5): */
2372     if (flags & 1) {
2373         PL_savestack_ix += 5;           /* Protect save in progress. */
2374         SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
2375     }
2376     if (flags & 4)
2377         PL_markstack_ptr++;             /* Protect mark. */
2378     if (flags & 8) {
2379         PL_retstack_ix++;
2380         PL_retstack[PL_retstack_ix] = NULL;
2381     }
2382     if (flags & 16)
2383         PL_scopestack_ix += 1;
2384     /* sv_2cv is too complicated, try a simpler variant first: */
2385     if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
2386         || SvTYPE(cv) != SVt_PVCV)
2387         cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
2388
2389     if (!cv || !CvROOT(cv)) {
2390         if (ckWARN(WARN_SIGNAL))
2391             Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
2392                 PL_sig_name[sig], (gv ? GvENAME(gv)
2393                                 : ((cv && CvGV(cv))
2394                                    ? GvENAME(CvGV(cv))
2395                                    : "__ANON__")));
2396         goto cleanup;
2397     }
2398
2399     if(PL_psig_name[sig]) {
2400         sv = SvREFCNT_inc(PL_psig_name[sig]);
2401         flags |= 64;
2402 #if !defined(PERL_IMPLICIT_CONTEXT)
2403         sig_sv = sv;
2404 #endif
2405     } else {
2406         sv = sv_newmortal();
2407         sv_setpv(sv,PL_sig_name[sig]);
2408     }
2409
2410     PUSHSTACKi(PERLSI_SIGNAL);
2411     PUSHMARK(SP);
2412     PUSHs(sv);
2413     PUTBACK;
2414
2415     call_sv((SV*)cv, G_DISCARD|G_EVAL);
2416
2417     POPSTACK;
2418     if (SvTRUE(ERRSV)) {
2419 #ifndef PERL_MICRO
2420 #ifdef HAS_SIGPROCMASK
2421         /* Handler "died", for example to get out of a restart-able read().
2422          * Before we re-do that on its behalf re-enable the signal which was
2423          * blocked by the system when we entered.
2424          */
2425         sigset_t set;
2426         sigemptyset(&set);
2427         sigaddset(&set,sig);
2428         sigprocmask(SIG_UNBLOCK, &set, NULL);
2429 #else
2430         /* Not clear if this will work */
2431         (void)rsignal(sig, SIG_IGN);
2432         (void)rsignal(sig, &Perl_csighandler);
2433 #endif
2434 #endif /* !PERL_MICRO */
2435         Perl_die(aTHX_ Nullformat);
2436     }
2437 cleanup:
2438     if (flags & 1)
2439         PL_savestack_ix -= 8; /* Unprotect save in progress. */
2440     if (flags & 4)
2441         PL_markstack_ptr--;
2442     if (flags & 8)
2443         PL_retstack_ix--;
2444     if (flags & 16)
2445         PL_scopestack_ix -= 1;
2446     if (flags & 64)
2447         SvREFCNT_dec(sv);
2448     PL_op = myop;                       /* Apparently not needed... */
2449
2450     PL_Sv = tSv;                        /* Restore global temporaries. */
2451     PL_Xpv = tXpv;
2452     return;
2453 }
2454
2455
2456 static void
2457 restore_magic(pTHX_ void *p)
2458 {
2459     MGS* mgs = SSPTR(PTR2IV(p), MGS*);
2460     SV* sv = mgs->mgs_sv;
2461
2462     if (!sv)
2463         return;
2464
2465     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2466     {
2467         if (mgs->mgs_flags)
2468             SvFLAGS(sv) |= mgs->mgs_flags;
2469         else
2470             mg_magical(sv);
2471         if (SvGMAGICAL(sv))
2472             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2473     }
2474
2475     mgs->mgs_sv = NULL;  /* mark the MGS structure as restored */
2476
2477     /* If we're still on top of the stack, pop us off.  (That condition
2478      * will be satisfied if restore_magic was called explicitly, but *not*
2479      * if it's being called via leave_scope.)
2480      * The reason for doing this is that otherwise, things like sv_2cv()
2481      * may leave alloc gunk on the savestack, and some code
2482      * (e.g. sighandler) doesn't expect that...
2483      */
2484     if (PL_savestack_ix == mgs->mgs_ss_ix)
2485     {
2486         I32 popval = SSPOPINT;
2487         assert(popval == SAVEt_DESTRUCTOR_X);
2488         PL_savestack_ix -= 2;
2489         popval = SSPOPINT;
2490         assert(popval == SAVEt_ALLOC);
2491         popval = SSPOPINT;
2492         PL_savestack_ix -= popval;
2493     }
2494
2495 }
2496
2497 static void
2498 unwind_handler_stack(pTHX_ void *p)
2499 {
2500     U32 flags = *(U32*)p;
2501
2502     if (flags & 1)
2503         PL_savestack_ix -= 5; /* Unprotect save in progress. */
2504     /* cxstack_ix-- Not needed, die already unwound it. */
2505 #if !defined(PERL_IMPLICIT_CONTEXT)
2506     if (flags & 64)
2507         SvREFCNT_dec(sig_sv);
2508 #endif
2509 }
2510
2511