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