mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (c) 1991-1997, 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 #include "perl.h"
  17
  18 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  19 #ifdef I_UNISTD
  20 # include <unistd.h>
  21 #endif
  22
  23 #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
  24 #  ifndef NGROUPS
  25 #    define NGROUPS 32
  26 #  endif
  27 #endif
  28
  29 /*
  30  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  31  */
  32
  33 struct magic_state {
  34     SV* mgs_sv;
  35     U32 mgs_flags;
  36 };
  37 typedef struct magic_state MGS;
  38
  39 static void restore_magic _((void *p));
  40
  41 static void
  42 save_magic(MGS *mgs, SV *sv)
  43 {
  44     assert(SvMAGICAL(sv));
  45
  46     mgs->mgs_sv = sv;
  47     mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
  48     SAVEDESTRUCTOR(restore_magic, mgs);
  49
  50     SvMAGICAL_off(sv);
  51     SvREADONLY_off(sv);
  52     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
  53 }
  54
  55 static void
  56 restore_magic(void *p)
  57 {
  58     MGS* mgs = (MGS*)p;
  59     SV* sv = mgs->mgs_sv;
  60
  61     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
  62     {
  63         if (mgs->mgs_flags)
  64             SvFLAGS(sv) |= mgs->mgs_flags;
  65         else
  66             mg_magical(sv);
  67         if (SvGMAGICAL(sv))
  68             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
  69     }
  70 }
  71
  72
  73 void
  74 mg_magical(SV *sv)
  75 {
  76     MAGIC* mg;
  77     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
  78         MGVTBL* vtbl = mg->mg_virtual;
  79         if (vtbl) {
  80             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
  81                 SvGMAGICAL_on(sv);
  82             if (vtbl->svt_set)
  83                 SvSMAGICAL_on(sv);
  84             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
  85                 SvRMAGICAL_on(sv);
  86         }
  87     }
  88 }
  89
  90 int
  91 mg_get(SV *sv)
  92 {
  93     MGS mgs;
  94     MAGIC* mg;
  95     MAGIC** mgp;
  96     int mgp_valid = 0;
  97
  98     ENTER;
  99     save_magic(&mgs, sv);
 100
 101     mgp = &SvMAGIC(sv);
 102     while ((mg = *mgp) != 0) {
 103         MGVTBL* vtbl = mg->mg_virtual;
 104         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
 105             (*vtbl->svt_get)(sv, mg);
 106             /* Ignore this magic if it's been deleted */
 107             if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) &&
 108                   (mg->mg_flags & MGf_GSKIP))
 109                 mgs.mgs_flags = 0;
 110         }
 111         /* Advance to next magic (complicated by possible deletion) */
 112         if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) {
 113             mgp = &mg->mg_moremagic;
 114             mgp_valid = 1;
 115         }
 116         else
 117             mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */
 118     }
 119
 120     LEAVE;
 121     return 0;
 122 }
 123
 124 int
 125 mg_set(SV *sv)
 126 {
 127     MGS mgs;
 128     MAGIC* mg;
 129     MAGIC* nextmg;
 130
 131     ENTER;
 132     save_magic(&mgs, sv);
 133
 134     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
 135         MGVTBL* vtbl = mg->mg_virtual;
 136         nextmg = mg->mg_moremagic;      /* it may delete itself */
 137         if (mg->mg_flags & MGf_GSKIP) {
 138             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
 139             mgs.mgs_flags = 0;
 140         }
 141         if (vtbl && vtbl->svt_set)
 142             (*vtbl->svt_set)(sv, mg);
 143     }
 144
 145     LEAVE;
 146     return 0;
 147 }
 148
 149 U32
 150 mg_len(SV *sv)
 151 {
 152     MAGIC* mg;
 153     char *junk;
 154     STRLEN len;
 155
 156     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 157         MGVTBL* vtbl = mg->mg_virtual;
 158         if (vtbl && vtbl->svt_len) {
 159             MGS mgs;
 160
 161             ENTER;
 162             save_magic(&mgs, sv);
 163             /* omit MGf_GSKIP -- not changed here */
 164             len = (*vtbl->svt_len)(sv, mg);
 165             LEAVE;
 166             return len;
 167         }
 168     }
 169
 170     junk = SvPV(sv, len);
 171     return len;
 172 }
 173
 174 int
 175 mg_clear(SV *sv)
 176 {
 177     MGS mgs;
 178     MAGIC* mg;
 179
 180     ENTER;
 181     save_magic(&mgs, sv);
 182
 183     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 184         MGVTBL* vtbl = mg->mg_virtual;
 185         /* omit GSKIP -- never set here */
 186
 187         if (vtbl && vtbl->svt_clear)
 188             (*vtbl->svt_clear)(sv, mg);
 189     }
 190
 191     LEAVE;
 192     return 0;
 193 }
 194
 195 MAGIC*
 196 mg_find(SV *sv, int type)
 197 {
 198     MAGIC* mg;
 199     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 200         if (mg->mg_type == type)
 201             return mg;
 202     }
 203     return 0;
 204 }
 205
 206 int
 207 mg_copy(SV *sv, SV *nsv, char *key, I32 klen)
 208 {
 209     int count = 0;
 210     MAGIC* mg;
 211     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 212         if (isUPPER(mg->mg_type)) {
 213             sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen);
 214             count++;
 215         }
 216     }
 217     return count;
 218 }
 219
 220 int
 221 mg_free(SV *sv)
 222 {
 223     MAGIC* mg;
 224     MAGIC* moremagic;
 225     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 226         MGVTBL* vtbl = mg->mg_virtual;
 227         moremagic = mg->mg_moremagic;
 228         if (vtbl && vtbl->svt_free)
 229             (*vtbl->svt_free)(sv, mg);
 230         if (mg->mg_ptr && mg->mg_type != 'g')
 231             if (mg->mg_len >= 0)
 232                 Safefree(mg->mg_ptr);
 233             else if (mg->mg_len == HEf_SVKEY)
 234                 SvREFCNT_dec((SV*)mg->mg_ptr);
 235         if (mg->mg_flags & MGf_REFCOUNTED)
 236             SvREFCNT_dec(mg->mg_obj);
 237         Safefree(mg);
 238     }
 239     SvMAGIC(sv) = 0;
 240     return 0;
 241 }
 242
 243 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
 244 #include <signal.h>
 245 #endif
 246
 247 U32
 248 magic_len(SV *sv, MAGIC *mg)
 249 {
 250     register I32 paren;
 251     register char *s;
 252     register I32 i;
 253     register REGEXP *rx;
 254     char *t;
 255
 256     switch (*mg->mg_ptr) {
 257     case '1': case '2': case '3': case '4':
 258     case '5': case '6': case '7': case '8': case '9': case '&':
 259         if (curpm && (rx = curpm->op_pmregexp)) {
 260             paren = atoi(mg->mg_ptr);
 261           getparen:
 262             if (paren <= rx->nparens &&
 263                 (s = rx->startp[paren]) &&
 264                 (t = rx->endp[paren]))
 265             {
 266                 i = t - s;
 267                 if (i >= 0)
 268                     return i;
 269             }
 270         }
 271         return 0;
 272     case '+':
 273         if (curpm && (rx = curpm->op_pmregexp)) {
 274             paren = rx->lastparen;
 275             if (paren)
 276                 goto getparen;
 277         }
 278         return 0;
 279     case '`':
 280         if (curpm && (rx = curpm->op_pmregexp)) {
 281             if ((s = rx->subbeg) && rx->startp[0]) {
 282                 i = rx->startp[0] - s;
 283                 if (i >= 0)
 284                     return i;
 285             }
 286         }
 287         return 0;
 288     case '\'':
 289         if (curpm && (rx = curpm->op_pmregexp)) {
 290             if (rx->subend && (s = rx->endp[0])) {
 291                 i = rx->subend - s;
 292                 if (i >= 0)
 293                     return i;
 294             }
 295         }
 296         return 0;
 297     case ',':
 298         return (STRLEN)ofslen;
 299     case '\\':
 300         return (STRLEN)orslen;
 301     }
 302     magic_get(sv,mg);
 303     if (!SvPOK(sv) && SvNIOK(sv))
 304         sv_2pv(sv, &na);
 305     if (SvPOK(sv))
 306         return SvCUR(sv);
 307     return 0;
 308 }
 309
 310 int
 311 magic_get(SV *sv, MAGIC *mg)
 312 {
 313     register I32 paren;
 314     register char *s;
 315     register I32 i;
 316     register REGEXP *rx;
 317     char *t;
 318
 319     switch (*mg->mg_ptr) {
 320     case '\001':                /* ^A */
 321         sv_setsv(sv, bodytarget);
 322         break;
 323     case '\004':                /* ^D */
 324         sv_setiv(sv, (IV)(debug & 32767));
 325         break;
 326     case '\005':  /* ^E */
 327 #ifdef VMS
 328         {
 329 #           include <descrip.h>
 330 #           include <starlet.h>
 331             char msg[255];
 332             $DESCRIPTOR(msgdsc,msg);
 333             sv_setnv(sv,(double) vaxc$errno);
 334             if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 335                 sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 336             else
 337                 sv_setpv(sv,"");
 338         }
 339 #else
 340 #ifdef OS2
 341         if (!(_emx_env & 0x200)) {      /* Under DOS */
 342             sv_setnv(sv, (double)errno);
 343             sv_setpv(sv, errno ? Strerror(errno) : "");
 344         } else {
 345             if (errno != errno_isOS2)
 346                 Perl_rc = _syserrno();
 347             sv_setnv(sv, (double)Perl_rc);
 348             sv_setpv(sv, os2error(Perl_rc));
 349         }
 350 #else
 351         sv_setnv(sv, (double)errno);
 352         sv_setpv(sv, errno ? Strerror(errno) : "");
 353 #endif
 354 #endif
 355         SvNOK_on(sv);   /* what a wonderful hack! */
 356         break;
 357     case '\006':                /* ^F */
 358         sv_setiv(sv, (IV)maxsysfd);
 359         break;
 360     case '\010':                /* ^H */
 361         sv_setiv(sv, (IV)hints);
 362         break;
 363     case '\t':                  /* ^I */
 364         if (inplace)
 365             sv_setpv(sv, inplace);
 366         else
 367             sv_setsv(sv, &sv_undef);
 368         break;
 369     case '\017':                /* ^O */
 370         sv_setpv(sv, osname);
 371         break;
 372     case '\020':                /* ^P */
 373         sv_setiv(sv, (IV)perldb);
 374         break;
 375     case '\023':                /* ^S */
 376         {
 377             dTHR;
 378             if (lex_state != LEX_NOTPARSING)
 379                 SvOK_off(sv);
 380             else if (in_eval)
 381                 sv_setiv(sv, 1);
 382             else
 383                 sv_setiv(sv, 0);
 384         }
 385         break;
 386     case '\024':                /* ^T */
 387 #ifdef BIG_TIME
 388         sv_setnv(sv, basetime);
 389 #else
 390         sv_setiv(sv, (IV)basetime);
 391 #endif
 392         break;
 393     case '\027':                /* ^W */
 394         sv_setiv(sv, (IV)dowarn);
 395         break;
 396     case '1': case '2': case '3': case '4':
 397     case '5': case '6': case '7': case '8': case '9': case '&':
 398         if (curpm && (rx = curpm->op_pmregexp)) {
 399             paren = atoi(GvENAME((GV*)mg->mg_obj));
 400           getparen:
 401             if (paren <= rx->nparens &&
 402                 (s = rx->startp[paren]) &&
 403                 (t = rx->endp[paren]))
 404             {
 405                 i = t - s;
 406               getrx:
 407                 if (i >= 0) {
 408                     bool was_tainted;
 409                     if (tainting) {
 410                         was_tainted = tainted;
 411                         tainted = FALSE;
 412                     }
 413                     sv_setpvn(sv,s,i);
 414                     if (tainting)
 415                         tainted = was_tainted || rx->exec_tainted;
 416                     break;
 417                 }
 418             }
 419         }
 420         sv_setsv(sv,&sv_undef);
 421         break;
 422     case '+':
 423         if (curpm && (rx = curpm->op_pmregexp)) {
 424             paren = rx->lastparen;
 425             if (paren)
 426                 goto getparen;
 427         }
 428         sv_setsv(sv,&sv_undef);
 429         break;
 430     case '`':
 431         if (curpm && (rx = curpm->op_pmregexp)) {
 432             if ((s = rx->subbeg) && rx->startp[0]) {
 433                 i = rx->startp[0] - s;
 434                 goto getrx;
 435             }
 436         }
 437         sv_setsv(sv,&sv_undef);
 438         break;
 439     case '\'':
 440         if (curpm && (rx = curpm->op_pmregexp)) {
 441             if (rx->subend && (s = rx->endp[0])) {
 442                 i = rx->subend - s;
 443                 goto getrx;
 444             }
 445         }
 446         sv_setsv(sv,&sv_undef);
 447         break;
 448     case '.':
 449 #ifndef lint
 450         if (GvIO(last_in_gv)) {
 451             sv_setiv(sv, (IV)IoLINES(GvIO(last_in_gv)));
 452         }
 453 #endif
 454         break;
 455     case '?':
 456         {
 457             dTHR;
 458             sv_setiv(sv, (IV)STATUS_CURRENT);
 459 #ifdef COMPLEX_STATUS
 460             LvTARGOFF(sv) = statusvalue;
 461             LvTARGLEN(sv) = statusvalue_vms;
 462 #endif
 463         }
 464         break;
 465     case '^':
 466         s = IoTOP_NAME(GvIOp(defoutgv));
 467         if (s)
 468             sv_setpv(sv,s);
 469         else {
 470             sv_setpv(sv,GvENAME(defoutgv));
 471             sv_catpv(sv,"_TOP");
 472         }
 473         break;
 474     case '~':
 475         s = IoFMT_NAME(GvIOp(defoutgv));
 476         if (!s)
 477             s = GvENAME(defoutgv);
 478         sv_setpv(sv,s);
 479         break;
 480 #ifndef lint
 481     case '=':
 482         sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(defoutgv)));
 483         break;
 484     case '-':
 485         sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(defoutgv)));
 486         break;
 487     case '%':
 488         sv_setiv(sv, (IV)IoPAGE(GvIOp(defoutgv)));
 489         break;
 490 #endif
 491     case ':':
 492         break;
 493     case '/':
 494         break;
 495     case '[':
 496         WITH_THR(sv_setiv(sv, (IV)curcop->cop_arybase));
 497         break;
 498     case '|':
 499         sv_setiv(sv, (IV)(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
 500         break;
 501     case ',':
 502         sv_setpvn(sv,ofs,ofslen);
 503         break;
 504     case '\\':
 505         sv_setpvn(sv,ors,orslen);
 506         break;
 507     case '#':
 508         sv_setpv(sv,ofmt);
 509         break;
 510     case '!':
 511 #ifdef VMS
 512         sv_setnv(sv, (double)((errno == EVMSERR) ? vaxc$errno : errno));
 513         sv_setpv(sv, errno ? Strerror(errno) : "");
 514 #else
 515         {
 516         int saveerrno = errno;
 517         sv_setnv(sv, (double)errno);
 518 #ifdef OS2
 519         if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
 520         else
 521 #endif
 522         sv_setpv(sv, errno ? Strerror(errno) : "");
 523         errno = saveerrno;
 524         }
 525 #endif
 526         SvNOK_on(sv);   /* what a wonderful hack! */
 527         break;
 528     case '<':
 529         sv_setiv(sv, (IV)uid);
 530         break;
 531     case '>':
 532         sv_setiv(sv, (IV)euid);
 533         break;
 534     case '(':
 535         sv_setiv(sv, (IV)gid);
 536         sv_setpvf(sv, "%Vd", (IV)gid);
 537         goto add_groups;
 538     case ')':
 539         sv_setiv(sv, (IV)egid);
 540         sv_setpvf(sv, "%Vd", (IV)egid);
 541       add_groups:
 542 #ifdef HAS_GETGROUPS
 543         {
 544             Groups_t gary[NGROUPS];
 545             i = getgroups(NGROUPS,gary);
 546             while (--i >= 0)
 547                 sv_catpvf(sv, " %Vd", (IV)gary[i]);
 548         }
 549 #endif
 550         SvIOK_on(sv);   /* what a wonderful hack! */
 551         break;
 552     case '*':
 553         break;
 554     case '0':
 555         break;
 556     }
 557     return 0;
 558 }
 559
 560 int
 561 magic_getuvar(SV *sv, MAGIC *mg)
 562 {
 563     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
 564
 565     if (uf && uf->uf_val)
 566         (*uf->uf_val)(uf->uf_index, sv);
 567     return 0;
 568 }
 569
 570 int
 571 magic_setenv(SV *sv, MAGIC *mg)
 572 {
 573     register char *s;
 574     char *ptr;
 575     STRLEN len, klen;
 576     I32 i;
 577
 578     s = SvPV(sv,len);
 579     ptr = MgPV(mg,klen);
 580     my_setenv(ptr, s);
 581
 582 #ifdef DYNAMIC_ENV_FETCH
 583      /* We just undefd an environment var.  Is a replacement */
 584      /* waiting in the wings? */
 585     if (!len) {
 586         SV **valp;
 587         if ((valp = hv_fetch(GvHVn(envgv), ptr, klen, FALSE)))
 588             s = SvPV(*valp, len);
 589     }
 590 #endif
 591
 592 #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32)
 593                             /* And you'll never guess what the dog had */
 594                             /*   in its mouth... */
 595     if (tainting) {
 596         MgTAINTEDDIR_off(mg);
 597 #ifdef VMS
 598         if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
 599             char pathbuf[256], eltbuf[256], *cp, *elt = s;
 600             struct stat sbuf;
 601             int i = 0, j = 0;
 602
 603             do {          /* DCL$PATH may be a search list */
 604                 while (1) {   /* as may dev portion of any element */
 605                     if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
 606                         if ( *(cp+1) == '.' || *(cp+1) == '-' ||
 607                              cando_by_name(S_IWUSR,0,elt) ) {
 608                             MgTAINTEDDIR_on(mg);
 609                             return 0;
 610                         }
 611                     }
 612                     if ((cp = strchr(elt, ':')) != Nullch)
 613                         *cp = '\0';
 614                     if (my_trnlnm(elt, eltbuf, j++))
 615                         elt = eltbuf;
 616                     else
 617                         break;
 618                 }
 619                 j = 0;
 620             } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
 621         }
 622 #endif /* VMS */
 623         if (s && klen == 4 && strEQ(ptr,"PATH")) {
 624             char *strend = s + len;
 625
 626             while (s < strend) {
 627                 char tmpbuf[256];
 628                 struct stat st;
 629                 s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
 630                              s, strend, ':', &i);
 631                 s++;
 632                 if (i >= sizeof tmpbuf   /* too long -- assume the worst */
 633                       || *tmpbuf != '/'
 634                       || (Stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
 635                     MgTAINTEDDIR_on(mg);
 636                     return 0;
 637                 }
 638             }
 639         }
 640     }
 641 #endif /* neither OS2 nor AMIGAOS nor WIN32 */
 642
 643     return 0;
 644 }
 645
 646 int
 647 magic_clearenv(SV *sv, MAGIC *mg)
 648 {
 649     my_setenv(MgPV(mg,na),Nullch);
 650     return 0;
 651 }
 652
 653 int
 654 magic_set_all_env(SV *sv, MAGIC *mg)
 655 {
 656 #if defined(VMS)
 657     die("Can't make list assignment to %%ENV on this system");
 658 #else
 659     dTHR;
 660     if (localizing) {
 661         HE* entry;
 662         magic_clear_all_env(sv,mg);
 663         hv_iterinit((HV*)sv);
 664         while (entry = hv_iternext((HV*)sv)) {
 665             I32 keylen;
 666             my_setenv(hv_iterkey(entry, &keylen),
 667                       SvPV(hv_iterval((HV*)sv, entry), na));
 668         }
 669     }
 670 #endif
 671     return 0;
 672 }
 673
 674 int
 675 magic_clear_all_env(SV *sv, MAGIC *mg)
 676 {
 677 #if defined(VMS)
 678     die("Can't make list assignment to %%ENV on this system");
 679 #else
 680 #ifdef WIN32
 681     char *envv = GetEnvironmentStrings();
 682     char *cur = envv;
 683     STRLEN len;
 684     while (*cur) {
 685         char *end = strchr(cur,'=');
 686         if (end && end != cur) {
 687             *end = '\0';
 688             my_setenv(cur,Nullch);
 689             *end = '=';
 690             cur += strlen(end+1)+1;
 691         }
 692         else if ((len = strlen(cur)))
 693             cur += len+1;
 694     }
 695     FreeEnvironmentStrings(envv);
 696 #else
 697     I32 i;
 698
 699     if (environ == origenviron)
 700         New(901, environ, 1, char*);
 701     else
 702         for (i = 0; environ[i]; i++)
 703             Safefree(environ[i]);
 704     environ[0] = Nullch;
 705
 706 #endif
 707 #endif
 708     return 0;
 709 }
 710
 711 int
 712 magic_getsig(SV *sv, MAGIC *mg)
 713 {
 714     I32 i;
 715     /* Are we fetching a signal entry? */
 716     i = whichsig(MgPV(mg,na));
 717     if (i) {
 718         if(psig_ptr[i])
 719             sv_setsv(sv,psig_ptr[i]);
 720         else {
 721             dTHR;               /* just for SvREFCNT_inc */
 722             Sighandler_t sigstate = rsignal_state(i);
 723
 724             /* cache state so we don't fetch it again */
 725             if(sigstate == SIG_IGN)
 726                 sv_setpv(sv,"IGNORE");
 727             else
 728                 sv_setsv(sv,&sv_undef);
 729             psig_ptr[i] = SvREFCNT_inc(sv);
 730             SvTEMP_off(sv);
 731         }
 732     }
 733     return 0;
 734 }
 735 int
 736 magic_clearsig(SV *sv, MAGIC *mg)
 737 {
 738     I32 i;
 739     /* Are we clearing a signal entry? */
 740     i = whichsig(MgPV(mg,na));
 741     if (i) {
 742         if(psig_ptr[i]) {
 743             SvREFCNT_dec(psig_ptr[i]);
 744             psig_ptr[i]=0;
 745         }
 746         if(psig_name[i]) {
 747             SvREFCNT_dec(psig_name[i]);
 748             psig_name[i]=0;
 749         }
 750     }
 751     return 0;
 752 }
 753
 754 int
 755 magic_setsig(SV *sv, MAGIC *mg)
 756 {
 757     dTHR;
 758     register char *s;
 759     I32 i;
 760     SV** svp;
 761
 762     s = MgPV(mg,na);
 763     if (*s == '_') {
 764         if (strEQ(s,"__DIE__"))
 765             svp = &diehook;
 766         else if (strEQ(s,"__WARN__"))
 767             svp = &warnhook;
 768         else if (strEQ(s,"__PARSE__"))
 769             svp = &parsehook;
 770         else
 771             croak("No such hook: %s", s);
 772         i = 0;
 773         if (*svp) {
 774             SvREFCNT_dec(*svp);
 775             *svp = 0;
 776         }
 777     }
 778     else {
 779         i = whichsig(s);        /* ...no, a brick */
 780         if (!i) {
 781             if (dowarn || strEQ(s,"ALARM"))
 782                 warn("No such signal: SIG%s", s);
 783             return 0;
 784         }
 785         SvREFCNT_dec(psig_name[i]);
 786         SvREFCNT_dec(psig_ptr[i]);
 787         psig_ptr[i] = SvREFCNT_inc(sv);
 788         SvTEMP_off(sv); /* Make sure it doesn't go away on us */
 789         psig_name[i] = newSVpv(s, strlen(s));
 790         SvREADONLY_on(psig_name[i]);
 791     }
 792     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
 793         if (i)
 794             (void)rsignal(i, sighandlerp);
 795         else
 796             *svp = SvREFCNT_inc(sv);
 797         return 0;
 798     }
 799     s = SvPV_force(sv,na);
 800     if (strEQ(s,"IGNORE")) {
 801         if (i)
 802             (void)rsignal(i, SIG_IGN);
 803         else
 804             *svp = 0;
 805     }
 806     else if (strEQ(s,"DEFAULT") || !*s) {
 807         if (i)
 808             (void)rsignal(i, SIG_DFL);
 809         else
 810             *svp = 0;
 811     }
 812     else {
 813         /*
 814          * We should warn if HINT_STRICT_REFS, but without
 815          * access to a known hint bit in a known OP, we can't
 816          * tell whether HINT_STRICT_REFS is in force or not.
 817          */
 818         if (!strchr(s,':') && !strchr(s,'\''))
 819             sv_setpv(sv, form("main::%s", s));
 820         if (i)
 821             (void)rsignal(i, sighandlerp);
 822         else
 823             *svp = SvREFCNT_inc(sv);
 824     }
 825     return 0;
 826 }
 827
 828 int
 829 magic_setisa(SV *sv, MAGIC *mg)
 830 {
 831     sub_generation++;
 832     return 0;
 833 }
 834
 835 #ifdef OVERLOAD
 836
 837 int
 838 magic_setamagic(SV *sv, MAGIC *mg)
 839 {
 840     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
 841     amagic_generation++;
 842
 843     return 0;
 844 }
 845 #endif /* OVERLOAD */
 846
 847 int
 848 magic_setnkeys(SV *sv, MAGIC *mg)
 849 {
 850     if (LvTARG(sv)) {
 851         hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
 852         LvTARG(sv) = Nullsv;    /* Don't allow a ref to reassign this. */
 853     }
 854     return 0;
 855 }
 856
 857 static int
 858 magic_methpack(SV *sv, MAGIC *mg, char *meth)
 859 {
 860     dTHR;
 861     dSP;
 862
 863     ENTER;
 864     SAVETMPS;
 865     PUSHMARK(sp);
 866     EXTEND(sp, 2);
 867     PUSHs(mg->mg_obj);
 868     if (mg->mg_ptr) {
 869         if (mg->mg_len >= 0)
 870             PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
 871         else if (mg->mg_len == HEf_SVKEY)
 872             PUSHs((SV*)mg->mg_ptr);
 873     }
 874     else if (mg->mg_type == 'p')
 875         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
 876     PUTBACK;
 877
 878     if (perl_call_method(meth, G_SCALAR))
 879         sv_setsv(sv, *stack_sp--);
 880
 881     FREETMPS;
 882     LEAVE;
 883     return 0;
 884 }
 885
 886 int
 887 magic_getpack(SV *sv, MAGIC *mg)
 888 {
 889     magic_methpack(sv,mg,"FETCH");
 890     if (mg->mg_ptr)
 891         mg->mg_flags |= MGf_GSKIP;
 892     return 0;
 893 }
 894
 895 int
 896 magic_setpack(SV *sv, MAGIC *mg)
 897 {
 898     dTHR;
 899     dSP;
 900
 901     PUSHMARK(sp);
 902     EXTEND(sp, 3);
 903     PUSHs(mg->mg_obj);
 904     if (mg->mg_ptr) {
 905         if (mg->mg_len >= 0)
 906             PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
 907         else if (mg->mg_len == HEf_SVKEY)
 908             PUSHs((SV*)mg->mg_ptr);
 909     }
 910     else if (mg->mg_type == 'p')
 911         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
 912     PUSHs(sv);
 913     PUTBACK;
 914
 915     perl_call_method("STORE", G_SCALAR|G_DISCARD);
 916
 917     return 0;
 918 }
 919
 920 int
 921 magic_clearpack(SV *sv, MAGIC *mg)
 922 {
 923     return magic_methpack(sv,mg,"DELETE");
 924 }
 925
 926 int magic_wipepack(SV *sv, MAGIC *mg)
 927 {
 928     dTHR;
 929     dSP;
 930
 931     PUSHMARK(sp);
 932     XPUSHs(mg->mg_obj);
 933     PUTBACK;
 934
 935     perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
 936
 937     return 0;
 938 }
 939
 940 int
 941 magic_nextpack(SV *sv, MAGIC *mg, SV *key)
 942 {
 943     dTHR;
 944     dSP;
 945     char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
 946
 947     ENTER;
 948     SAVETMPS;
 949     PUSHMARK(sp);
 950     EXTEND(sp, 2);
 951     PUSHs(mg->mg_obj);
 952     if (SvOK(key))
 953         PUSHs(key);
 954     PUTBACK;
 955
 956     if (perl_call_method(meth, G_SCALAR))
 957         sv_setsv(key, *stack_sp--);
 958
 959     FREETMPS;
 960     LEAVE;
 961     return 0;
 962 }
 963
 964 int
 965 magic_existspack(SV *sv, MAGIC *mg)
 966 {
 967     return magic_methpack(sv,mg,"EXISTS");
 968 }
 969
 970 int
 971 magic_setdbline(SV *sv, MAGIC *mg)
 972 {
 973     dTHR;
 974     OP *o;
 975     I32 i;
 976     GV* gv;
 977     SV** svp;
 978
 979     gv = DBline;
 980     i = SvTRUE(sv);
 981     svp = av_fetch(GvAV(gv),
 982                      atoi(MgPV(mg,na)), FALSE);
 983     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
 984         o->op_private = i;
 985     else
 986         warn("Can't break at that line\n");
 987     return 0;
 988 }
 989
 990 int
 991 magic_getarylen(SV *sv, MAGIC *mg)
 992 {
 993     dTHR;
 994     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
 995     return 0;
 996 }
 997
 998 int
 999 magic_setarylen(SV *sv, MAGIC *mg)
1000 {
1001     dTHR;
1002     av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
1003     return 0;
1004 }
1005
1006 int
1007 magic_getpos(SV *sv, MAGIC *mg)
1008 {
1009     SV* lsv = LvTARG(sv);
1010
1011     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
1012         mg = mg_find(lsv, 'g');
1013         if (mg && mg->mg_len >= 0) {
1014             dTHR;
1015             sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
1016             return 0;
1017         }
1018     }
1019     (void)SvOK_off(sv);
1020     return 0;
1021 }
1022
1023 int
1024 magic_setpos(SV *sv, MAGIC *mg)
1025 {
1026     SV* lsv = LvTARG(sv);
1027     SSize_t pos;
1028     STRLEN len;
1029
1030     mg = 0;
1031
1032     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
1033         mg = mg_find(lsv, 'g');
1034     if (!mg) {
1035         if (!SvOK(sv))
1036             return 0;
1037         sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
1038         mg = mg_find(lsv, 'g');
1039     }
1040     else if (!SvOK(sv)) {
1041         mg->mg_len = -1;
1042         return 0;
1043     }
1044     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
1045
1046     WITH_THR(pos = SvIV(sv) - curcop->cop_arybase);
1047     if (pos < 0) {
1048         pos += len;
1049         if (pos < 0)
1050             pos = 0;
1051     }
1052     else if (pos > len)
1053         pos = len;
1054     mg->mg_len = pos;
1055     mg->mg_flags &= ~MGf_MINMATCH;
1056
1057     return 0;
1058 }
1059
1060 int
1061 magic_getglob(SV *sv, MAGIC *mg)
1062 {
1063     if (SvFAKE(sv)) {                   /* FAKE globs can get coerced */
1064         SvFAKE_off(sv);
1065         gv_efullname3(sv,((GV*)sv), "*");
1066         SvFAKE_on(sv);
1067     }
1068     else
1069         gv_efullname3(sv,((GV*)sv), "*");       /* a gv value, be nice */
1070     return 0;
1071 }
1072
1073 int
1074 magic_setglob(SV *sv, MAGIC *mg)
1075 {
1076     register char *s;
1077     GV* gv;
1078
1079     if (!SvOK(sv))
1080         return 0;
1081     s = SvPV(sv, na);
1082     if (*s == '*' && s[1])
1083         s++;
1084     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
1085     if (sv == (SV*)gv)
1086         return 0;
1087     if (GvGP(sv))
1088         gp_free((GV*)sv);
1089     GvGP(sv) = gp_ref(GvGP(gv));
1090     return 0;
1091 }
1092
1093 int
1094 magic_setsubstr(SV *sv, MAGIC *mg)
1095 {
1096     STRLEN len;
1097     char *tmps = SvPV(sv,len);
1098     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
1099     return 0;
1100 }
1101
1102 int
1103 magic_gettaint(SV *sv, MAGIC *mg)
1104 {
1105     TAINT_IF((mg->mg_len & 1) ||
1106              (mg->mg_len & 2) && mg->mg_obj == sv);     /* kludge */
1107     return 0;
1108 }
1109
1110 int
1111 magic_settaint(SV *sv, MAGIC *mg)
1112 {
1113     dTHR;
1114     if (localizing) {
1115         if (localizing == 1)
1116             mg->mg_len <<= 1;
1117         else
1118             mg->mg_len >>= 1;
1119     }
1120     else if (tainted)
1121         mg->mg_len |= 1;
1122     else
1123         mg->mg_len &= ~1;
1124     return 0;
1125 }
1126
1127 int
1128 magic_setvec(SV *sv, MAGIC *mg)
1129 {
1130     do_vecset(sv);      /* XXX slurp this routine */
1131     return 0;
1132 }
1133
1134 int
1135 magic_getdefelem(SV *sv, MAGIC *mg)
1136 {
1137     SV *targ = Nullsv;
1138     if (LvTARGLEN(sv)) {
1139         if (mg->mg_obj) {
1140             HV* hv = (HV*)LvTARG(sv);
1141             HE* he = hv_fetch_ent(hv, mg->mg_obj, FALSE, 0);
1142             if (he)
1143                 targ = HeVAL(he);
1144         }
1145         else {
1146             AV* av = (AV*)LvTARG(sv);
1147             if ((I32)LvTARGOFF(sv) <= AvFILL(av))
1148                 targ = AvARRAY(av)[LvTARGOFF(sv)];
1149         }
1150         if (targ && targ != &sv_undef) {
1151             dTHR;               /* just for SvREFCNT_dec */
1152             /* somebody else defined it for us */
1153             SvREFCNT_dec(LvTARG(sv));
1154             LvTARG(sv) = SvREFCNT_inc(targ);
1155             LvTARGLEN(sv) = 0;
1156             SvREFCNT_dec(mg->mg_obj);
1157             mg->mg_obj = Nullsv;
1158             mg->mg_flags &= ~MGf_REFCOUNTED;
1159         }
1160     }
1161     else
1162         targ = LvTARG(sv);
1163     sv_setsv(sv, targ ? targ : &sv_undef);
1164     return 0;
1165 }
1166
1167 int
1168 magic_setdefelem(SV *sv, MAGIC *mg)
1169 {
1170     if (LvTARGLEN(sv))
1171         vivify_defelem(sv);
1172     if (LvTARG(sv)) {
1173         sv_setsv(LvTARG(sv), sv);
1174         SvSETMAGIC(LvTARG(sv));
1175     }
1176     return 0;
1177 }
1178
1179 int
1180 magic_freedefelem(SV *sv, MAGIC *mg)
1181 {
1182     SvREFCNT_dec(LvTARG(sv));
1183     return 0;
1184 }
1185
1186 void
1187 vivify_defelem(SV *sv)
1188 {
1189     dTHR;                       /* just for SvREFCNT_inc and SvREFCNT_dec*/
1190     MAGIC* mg;
1191     SV* value;
1192
1193     if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
1194         return;
1195     if (mg->mg_obj) {
1196         HV* hv = (HV*)LvTARG(sv);
1197         HE* he = hv_fetch_ent(hv, mg->mg_obj, TRUE, 0);
1198         if (!he || (value = HeVAL(he)) == &sv_undef)
1199             croak(no_helem, SvPV(mg->mg_obj, na));
1200     }
1201     else {
1202         AV* av = (AV*)LvTARG(sv);
1203         if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
1204             LvTARG(sv) = Nullsv;        /* array can't be extended */
1205         else {
1206             SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
1207             if (!svp || (value = *svp) == &sv_undef)
1208                 croak(no_aelem, (I32)LvTARGOFF(sv));
1209         }
1210     }
1211     (void)SvREFCNT_inc(value);
1212     SvREFCNT_dec(LvTARG(sv));
1213     LvTARG(sv) = value;
1214     LvTARGLEN(sv) = 0;
1215     SvREFCNT_dec(mg->mg_obj);
1216     mg->mg_obj = Nullsv;
1217     mg->mg_flags &= ~MGf_REFCOUNTED;
1218 }
1219
1220 int
1221 magic_setmglob(SV *sv, MAGIC *mg)
1222 {
1223     mg->mg_len = -1;
1224     SvSCREAM_off(sv);
1225     return 0;
1226 }
1227
1228 int
1229 magic_setbm(SV *sv, MAGIC *mg)
1230 {
1231     sv_unmagic(sv, 'B');
1232     SvVALID_off(sv);
1233     return 0;
1234 }
1235
1236 int
1237 magic_setfm(SV *sv, MAGIC *mg)
1238 {
1239     sv_unmagic(sv, 'f');
1240     SvCOMPILED_off(sv);
1241     return 0;
1242 }
1243
1244 int
1245 magic_setuvar(SV *sv, MAGIC *mg)
1246 {
1247     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
1248
1249     if (uf && uf->uf_set)
1250         (*uf->uf_set)(uf->uf_index, sv);
1251     return 0;
1252 }
1253
1254 #ifdef USE_LOCALE_COLLATE
1255 int
1256 magic_setcollxfrm(SV *sv, MAGIC *mg)
1257 {
1258     /*
1259      * René Descartes said "I think not."
1260      * and vanished with a faint plop.
1261      */
1262     if (mg->mg_ptr) {
1263         Safefree(mg->mg_ptr);
1264         mg->mg_ptr = NULL;
1265         mg->mg_len = -1;
1266     }
1267     return 0;
1268 }
1269 #endif /* USE_LOCALE_COLLATE */
1270
1271 int
1272 magic_set(SV *sv, MAGIC *mg)
1273 {
1274     dTHR;
1275     register char *s;
1276     I32 i;
1277     STRLEN len;
1278     switch (*mg->mg_ptr) {
1279     case '\001':        /* ^A */
1280         sv_setsv(bodytarget, sv);
1281         break;
1282     case '\004':        /* ^D */
1283         debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
1284         DEBUG_x(dump_all());
1285         break;
1286     case '\005':  /* ^E */
1287 #ifdef VMS
1288         set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1289 #else
1290         /* will anyone ever use this? */
1291         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
1292 #endif
1293         break;
1294     case '\006':        /* ^F */
1295         maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1296         break;
1297     case '\010':        /* ^H */
1298         hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1299         break;
1300     case '\t':  /* ^I */
1301         if (inplace)
1302             Safefree(inplace);
1303         if (SvOK(sv))
1304             inplace = savepv(SvPV(sv,na));
1305         else
1306             inplace = Nullch;
1307         break;
1308     case '\017':        /* ^O */
1309         if (osname)
1310             Safefree(osname);
1311         if (SvOK(sv))
1312             osname = savepv(SvPV(sv,na));
1313         else
1314             osname = Nullch;
1315         break;
1316     case '\020':        /* ^P */
1317         perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1318         break;
1319     case '\024':        /* ^T */
1320 #ifdef BIG_TIME
1321         basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
1322 #else
1323         basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1324 #endif
1325         break;
1326     case '\027':        /* ^W */
1327         dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1328         break;
1329     case '.':
1330         if (localizing) {
1331             if (localizing == 1)
1332                 save_sptr((SV**)&last_in_gv);
1333         }
1334         else if (SvOK(sv) && GvIO(last_in_gv))
1335             IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
1336         break;
1337     case '^':
1338         Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1339         IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1340         IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1341         break;
1342     case '~':
1343         Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1344         IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1345         IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1346         break;
1347     case '=':
1348         IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1349         break;
1350     case '-':
1351         IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1352         if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1353             IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
1354         break;
1355     case '%':
1356         IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1357         break;
1358     case '|':
1359         {
1360             IO *io = GvIOp(defoutgv);
1361             if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
1362                 IoFLAGS(io) &= ~IOf_FLUSH;
1363             else {
1364                 if (!(IoFLAGS(io) & IOf_FLUSH)) {
1365                     PerlIO *ofp = IoOFP(io);
1366                     if (ofp)
1367                         (void)PerlIO_flush(ofp);
1368                     IoFLAGS(io) |= IOf_FLUSH;
1369                 }
1370             }
1371         }
1372         break;
1373     case '*':
1374         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1375         multiline = (i != 0);
1376         break;
1377     case '/':
1378         SvREFCNT_dec(nrs);
1379         nrs = newSVsv(sv);
1380         SvREFCNT_dec(rs);
1381         rs = SvREFCNT_inc(nrs);
1382         break;
1383     case '\\':
1384         if (ors)
1385             Safefree(ors);
1386         if (SvOK(sv) || SvGMAGICAL(sv))
1387             ors = savepv(SvPV(sv,orslen));
1388         else {
1389             ors = Nullch;
1390             orslen = 0;
1391         }
1392         break;
1393     case ',':
1394         if (ofs)
1395             Safefree(ofs);
1396         ofs = savepv(SvPV(sv, ofslen));
1397         break;
1398     case '#':
1399         if (ofmt)
1400             Safefree(ofmt);
1401         ofmt = savepv(SvPV(sv,na));
1402         break;
1403     case '[':
1404         compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1405         break;
1406     case '?':
1407 #ifdef COMPLEX_STATUS
1408         if (localizing == 2) {
1409             statusvalue = LvTARGOFF(sv);
1410             statusvalue_vms = LvTARGLEN(sv);
1411         }
1412         else
1413 #endif
1414 #ifdef VMSISH_STATUS
1415         if (VMSISH_STATUS)
1416             STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
1417         else
1418 #endif
1419             STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1420         break;
1421     case '!':
1422         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),
1423                  (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
1424         break;
1425     case '<':
1426         uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1427         if (delaymagic) {
1428             delaymagic |= DM_RUID;
1429             break;                              /* don't do magic till later */
1430         }
1431 #ifdef HAS_SETRUID
1432         (void)setruid((Uid_t)uid);
1433 #else
1434 #ifdef HAS_SETREUID
1435         (void)setreuid((Uid_t)uid, (Uid_t)-1);
1436 #else
1437 #ifdef HAS_SETRESUID
1438       (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
1439 #else
1440         if (uid == euid)                /* special case $< = $> */
1441             (void)setuid(uid);
1442         else {
1443             uid = (I32)getuid();
1444             croak("setruid() not implemented");
1445         }
1446 #endif
1447 #endif
1448 #endif
1449         uid = (I32)getuid();
1450         tainting |= (uid && (euid != uid || egid != gid));
1451         break;
1452     case '>':
1453         euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1454         if (delaymagic) {
1455             delaymagic |= DM_EUID;
1456             break;                              /* don't do magic till later */
1457         }
1458 #ifdef HAS_SETEUID
1459         (void)seteuid((Uid_t)euid);
1460 #else
1461 #ifdef HAS_SETREUID
1462         (void)setreuid((Uid_t)-1, (Uid_t)euid);
1463 #else
1464 #ifdef HAS_SETRESUID
1465         (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
1466 #else
1467         if (euid == uid)                /* special case $> = $< */
1468             setuid(euid);
1469         else {
1470             euid = (I32)geteuid();
1471             croak("seteuid() not implemented");
1472         }
1473 #endif
1474 #endif
1475 #endif
1476         euid = (I32)geteuid();
1477         tainting |= (uid && (euid != uid || egid != gid));
1478         break;
1479     case '(':
1480         gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1481         if (delaymagic) {
1482             delaymagic |= DM_RGID;
1483             break;                              /* don't do magic till later */
1484         }
1485 #ifdef HAS_SETRGID
1486         (void)setrgid((Gid_t)gid);
1487 #else
1488 #ifdef HAS_SETREGID
1489         (void)setregid((Gid_t)gid, (Gid_t)-1);
1490 #else
1491 #ifdef HAS_SETRESGID
1492       (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
1493 #else
1494         if (gid == egid)                        /* special case $( = $) */
1495             (void)setgid(gid);
1496         else {
1497             gid = (I32)getgid();
1498             croak("setrgid() not implemented");
1499         }
1500 #endif
1501 #endif
1502 #endif
1503         gid = (I32)getgid();
1504         tainting |= (uid && (euid != uid || egid != gid));
1505         break;
1506     case ')':
1507 #ifdef HAS_SETGROUPS
1508         {
1509             char *p = SvPV(sv, na);
1510             Groups_t gary[NGROUPS];
1511
1512             SET_NUMERIC_STANDARD();
1513             while (isSPACE(*p))
1514                 ++p;
1515             egid = I_V(atof(p));
1516             for (i = 0; i < NGROUPS; ++i) {
1517                 while (*p && !isSPACE(*p))
1518                     ++p;
1519                 while (isSPACE(*p))
1520                     ++p;
1521                 if (!*p)
1522                     break;
1523                 gary[i] = I_V(atof(p));
1524             }
1525             if (i)
1526                 (void)setgroups(i, gary);
1527         }
1528 #else  /* HAS_SETGROUPS */
1529         egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1530 #endif /* HAS_SETGROUPS */
1531         if (delaymagic) {
1532             delaymagic |= DM_EGID;
1533             break;                              /* don't do magic till later */
1534         }
1535 #ifdef HAS_SETEGID
1536         (void)setegid((Gid_t)egid);
1537 #else
1538 #ifdef HAS_SETREGID
1539         (void)setregid((Gid_t)-1, (Gid_t)egid);
1540 #else
1541 #ifdef HAS_SETRESGID
1542         (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
1543 #else
1544         if (egid == gid)                        /* special case $) = $( */
1545             (void)setgid(egid);
1546         else {
1547             egid = (I32)getegid();
1548             croak("setegid() not implemented");
1549         }
1550 #endif
1551 #endif
1552 #endif
1553         egid = (I32)getegid();
1554         tainting |= (uid && (euid != uid || egid != gid));
1555         break;
1556     case ':':
1557         chopset = SvPV_force(sv,na);
1558         break;
1559     case '0':
1560         if (!origalen) {
1561             s = origargv[0];
1562             s += strlen(s);
1563             /* See if all the arguments are contiguous in memory */
1564             for (i = 1; i < origargc; i++) {
1565                 if (origargv[i] == s + 1
1566 #ifdef OS2
1567                     || origargv[i] == s + 2
1568 #endif
1569                    )
1570                     s += strlen(++s);   /* this one is ok too */
1571                 else
1572                     break;
1573             }
1574             /* can grab env area too? */
1575             if (origenviron && (origenviron[0] == s + 1
1576 #ifdef OS2
1577                                 || (origenviron[0] == s + 9 && (s += 8))
1578 #endif
1579                )) {
1580                 my_setenv("NoNe  SuCh", Nullch);
1581                                             /* force copy of environment */
1582                 for (i = 0; origenviron[i]; i++)
1583                     if (origenviron[i] == s + 1)
1584                         s += strlen(++s);
1585                     else
1586                         break;
1587             }
1588             origalen = s - origargv[0];
1589         }
1590         s = SvPV_force(sv,len);
1591         i = len;
1592         if (i >= origalen) {
1593             i = origalen;
1594             /* don't allow system to limit $0 seen by script */
1595             /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
1596             Copy(s, origargv[0], i, char);
1597             s = origargv[0]+i;
1598             *s = '\0';
1599         }
1600         else {
1601             Copy(s, origargv[0], i, char);
1602             s = origargv[0]+i;
1603             *s++ = '\0';
1604             while (++i < origalen)
1605                 *s++ = ' ';
1606             s = origargv[0]+i;
1607             for (i = 1; i < origargc; i++)
1608                 origargv[i] = Nullch;
1609         }
1610         break;
1611     }
1612     return 0;
1613 }
1614
1615 #ifdef USE_THREADS
1616 int
1617 magic_mutexfree(SV *sv, MAGIC *mg)
1618 {
1619     dTHR;
1620     DEBUG_L(PerlIO_printf(PerlIO_stderr(), "0x%lx: magic_mutexfree 0x%lx\n",
1621                           (unsigned long)thr, (unsigned long)sv);)
1622     if (MgOWNER(mg))
1623         croak("panic: magic_mutexfree");
1624     MUTEX_DESTROY(MgMUTEXP(mg));
1625     COND_DESTROY(MgCONDP(mg));
1626     SvREFCNT_dec(sv);
1627     return 0;
1628 }
1629 #endif /* USE_THREADS */
1630
1631 I32
1632 whichsig(char *sig)
1633 {
1634     register char **sigv;
1635
1636     for (sigv = sig_name+1; *sigv; sigv++)
1637         if (strEQ(sig,*sigv))
1638             return sig_num[sigv - sig_name];
1639 #ifdef SIGCLD
1640     if (strEQ(sig,"CHLD"))
1641         return SIGCLD;
1642 #endif
1643 #ifdef SIGCHLD
1644     if (strEQ(sig,"CLD"))
1645         return SIGCHLD;
1646 #endif
1647     return 0;
1648 }
1649
1650 static SV* sig_sv;
1651
1652 static void
1653 unwind_handler_stack(void *p)
1654 {
1655     dTHR;
1656     U32 flags = *(U32*)p;
1657
1658     if (flags & 1)
1659         savestack_ix -= 5; /* Unprotect save in progress. */
1660     /* cxstack_ix-- Not needed, die already unwound it. */
1661     if (flags & 64)
1662         SvREFCNT_dec(sig_sv);
1663 }
1664
1665 Signal_t
1666 sighandler(int sig)
1667 {
1668     dTHR;
1669     dSP;
1670     GV *gv;
1671     HV *st;
1672     SV *sv, *tSv = Sv;
1673     CV *cv;
1674     AV *oldstack;
1675     OP *myop = op;
1676     U32 flags = 0;
1677     I32 o_save_i = savestack_ix, type;
1678     CONTEXT *cx;
1679     XPV *tXpv = Xpv;
1680
1681     if (savestack_ix + 15 <= savestack_max)
1682         flags |= 1;
1683     if (cxstack_ix < cxstack_max - 2)
1684         flags |= 2;
1685     if (markstack_ptr < markstack_max - 2)
1686         flags |= 4;
1687     if (retstack_ix < retstack_max - 2)
1688         flags |= 8;
1689     if (scopestack_ix < scopestack_max - 3)
1690         flags |= 16;
1691
1692     if (flags & 2) {            /* POPBLOCK may decrease cxstack too early. */
1693         cxstack_ix++;           /* Protect from overwrite. */
1694         cx = &cxstack[cxstack_ix];
1695         type = cx->cx_type;             /* Can be during partial write. */
1696         cx->cx_type = CXt_NULL;         /* Make it safe for unwind. */
1697     }
1698     if (!psig_ptr[sig])
1699         die("Signal SIG%s received, but no signal handler set.\n",
1700             sig_name[sig]);
1701
1702     /* Max number of items pushed there is 3*n or 4. We cannot fix
1703        infinity, so we fix 4 (in fact 5): */
1704     if (flags & 1) {
1705         savestack_ix += 5;              /* Protect save in progress. */
1706         o_save_i = savestack_ix;
1707         SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
1708     }
1709     if (flags & 4)
1710         markstack_ptr++;                /* Protect mark. */
1711     if (flags & 8) {
1712         retstack_ix++;
1713         retstack[retstack_ix] = NULL;
1714     }
1715     if (flags & 16)
1716         scopestack_ix += 1;
1717     /* sv_2cv is too complicated, try a simpler variant first: */
1718     if (!SvROK(psig_ptr[sig]) || !(cv = (CV*)SvRV(psig_ptr[sig]))
1719         || SvTYPE(cv) != SVt_PVCV)
1720         cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
1721
1722     if (!cv || !CvROOT(cv)) {
1723         if (dowarn)
1724             warn("SIG%s handler \"%s\" not defined.\n",
1725                 sig_name[sig], GvENAME(gv) );
1726         return;
1727     }
1728
1729     oldstack = curstack;
1730     if (curstack != signalstack)
1731         AvFILL(signalstack) = 0;
1732     SWITCHSTACK(curstack, signalstack);
1733
1734     if(psig_name[sig]) {
1735         sv = SvREFCNT_inc(psig_name[sig]);
1736         flags |= 64;
1737         sig_sv = sv;
1738     } else {
1739         sv = sv_newmortal();
1740         sv_setpv(sv,sig_name[sig]);
1741     }
1742     PUSHMARK(sp);
1743     PUSHs(sv);
1744     PUTBACK;
1745
1746     perl_call_sv((SV*)cv, G_DISCARD);
1747
1748     SWITCHSTACK(signalstack, oldstack);
1749     if (flags & 1)
1750         savestack_ix -= 8; /* Unprotect save in progress. */
1751     if (flags & 2) {
1752         cxstack[cxstack_ix].cx_type = type;
1753         cxstack_ix -= 1;
1754     }
1755     if (flags & 4)
1756         markstack_ptr--;
1757     if (flags & 8)
1758         retstack_ix--;
1759     if (flags & 16)
1760         scopestack_ix -= 1;
1761     if (flags & 64)
1762         SvREFCNT_dec(sv);
1763     op = myop;                  /* Apparently not needed... */
1764
1765     Sv = tSv;                   /* Restore global temporaries. */
1766     Xpv = tXpv;
1767     return;
1768 }