mg.c

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