mg.c

   1 /*    mg.c
   2  *
   3  *    Copyright (c) 1991-1994, 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 /* Omit -- it causes too much grief on mixed systems.
  19 #ifdef I_UNISTD
  20 # include <unistd.h>
  21 #endif
  22 */
  23
  24
  25 void
  26 mg_magical(sv)
  27 SV* sv;
  28 {
  29     MAGIC* mg;
  30     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
  31         MGVTBL* vtbl = mg->mg_virtual;
  32         if (vtbl) {
  33             if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
  34                 SvGMAGICAL_on(sv);
  35             if (vtbl->svt_set)
  36                 SvSMAGICAL_on(sv);
  37             if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
  38                 SvRMAGICAL_on(sv);
  39         }
  40     }
  41 }
  42
  43 int
  44 mg_get(sv)
  45 SV* sv;
  46 {
  47     MAGIC* mg;
  48     U32 savemagic = SvMAGICAL(sv) | SvREADONLY(sv);
  49
  50     assert(SvGMAGICAL(sv));
  51     SvMAGICAL_off(sv);
  52     SvREADONLY_off(sv);
  53     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
  54
  55     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
  56         MGVTBL* vtbl = mg->mg_virtual;
  57         if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
  58             (*vtbl->svt_get)(sv, mg);
  59             if (mg->mg_flags & MGf_GSKIP)
  60                 savemagic = 0;
  61         }
  62     }
  63
  64     if (savemagic)
  65         SvFLAGS(sv) |= savemagic;
  66     else
  67         mg_magical(sv);
  68     if (SvGMAGICAL(sv))
  69         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
  70
  71     return 0;
  72 }
  73
  74 int
  75 mg_set(sv)
  76 SV* sv;
  77 {
  78     MAGIC* mg;
  79     MAGIC* nextmg;
  80     U32 savemagic = SvMAGICAL(sv);
  81
  82     SvMAGICAL_off(sv);
  83
  84     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
  85         MGVTBL* vtbl = mg->mg_virtual;
  86         nextmg = mg->mg_moremagic;      /* it may delete itself */
  87         if (mg->mg_flags & MGf_GSKIP) {
  88             mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
  89             savemagic = 0;
  90         }
  91         if (vtbl && vtbl->svt_set)
  92             (*vtbl->svt_set)(sv, mg);
  93     }
  94
  95     if (SvMAGIC(sv)) {
  96         if (savemagic)
  97             SvFLAGS(sv) |= savemagic;
  98         else
  99             mg_magical(sv);
 100         if (SvGMAGICAL(sv))
 101             SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
 102     }
 103
 104     return 0;
 105 }
 106
 107 U32
 108 mg_len(sv)
 109 SV* sv;
 110 {
 111     MAGIC* mg;
 112     char *junk;
 113     STRLEN len;
 114
 115     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 116         MGVTBL* vtbl = mg->mg_virtual;
 117         if (vtbl && vtbl->svt_len) {
 118             U32 savemagic = SvMAGICAL(sv);
 119
 120             SvMAGICAL_off(sv);
 121             SvFLAGS(sv) |= (SvFLAGS(sv)&(SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 122
 123             /* omit MGf_GSKIP -- not changed here */
 124             len = (*vtbl->svt_len)(sv, mg);
 125
 126             SvFLAGS(sv) |= savemagic;
 127             if (SvGMAGICAL(sv))
 128                 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
 129
 130             return len;
 131         }
 132     }
 133
 134     junk = SvPV(sv, len);
 135     return len;
 136 }
 137
 138 int
 139 mg_clear(sv)
 140 SV* sv;
 141 {
 142     MAGIC* mg;
 143     U32 savemagic = SvMAGICAL(sv);
 144
 145     SvMAGICAL_off(sv);
 146     SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 147
 148     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 149         MGVTBL* vtbl = mg->mg_virtual;
 150         /* omit GSKIP -- never set here */
 151
 152         if (vtbl && vtbl->svt_clear)
 153             (*vtbl->svt_clear)(sv, mg);
 154     }
 155
 156     SvFLAGS(sv) |= savemagic;
 157     if (SvGMAGICAL(sv))
 158         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
 159
 160     return 0;
 161 }
 162
 163 MAGIC*
 164 mg_find(sv, type)
 165 SV* sv;
 166 int type;
 167 {
 168     MAGIC* mg;
 169     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 170         if (mg->mg_type == type)
 171             return mg;
 172     }
 173     return 0;
 174 }
 175
 176 int
 177 mg_copy(sv, nsv, key, klen)
 178 SV* sv;
 179 SV* nsv;
 180 char *key;
 181 STRLEN klen;
 182 {
 183     int count = 0;
 184     MAGIC* mg;
 185     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 186         if (isUPPER(mg->mg_type)) {
 187             sv_magic(nsv, mg->mg_obj, toLOWER(mg->mg_type), key, klen);
 188             count++;
 189         }
 190     }
 191     return count;
 192 }
 193
 194 int
 195 mg_free(sv)
 196 SV* sv;
 197 {
 198     MAGIC* mg;
 199     MAGIC* moremagic;
 200     for (mg = SvMAGIC(sv); mg; mg = moremagic) {
 201         MGVTBL* vtbl = mg->mg_virtual;
 202         moremagic = mg->mg_moremagic;
 203         if (vtbl && vtbl->svt_free)
 204             (*vtbl->svt_free)(sv, mg);
 205         if (mg->mg_ptr && mg->mg_type != 'g')
 206             Safefree(mg->mg_ptr);
 207         if (mg->mg_flags & MGf_REFCOUNTED)
 208             SvREFCNT_dec(mg->mg_obj);
 209         Safefree(mg);
 210     }
 211     SvMAGIC(sv) = 0;
 212     return 0;
 213 }
 214
 215 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
 216 #include <signal.h>
 217 #endif
 218
 219 U32
 220 magic_len(sv, mg)
 221 SV *sv;
 222 MAGIC *mg;
 223 {
 224     register I32 paren;
 225     register char *s;
 226     register I32 i;
 227     char *t;
 228
 229     switch (*mg->mg_ptr) {
 230     case '1': case '2': case '3': case '4':
 231     case '5': case '6': case '7': case '8': case '9': case '&':
 232         if (curpm) {
 233             paren = atoi(mg->mg_ptr);
 234           getparen:
 235             if (curpm->op_pmregexp &&
 236               paren <= curpm->op_pmregexp->nparens &&
 237               (s = curpm->op_pmregexp->startp[paren]) &&
 238               (t = curpm->op_pmregexp->endp[paren]) ) {
 239                 i = t - s;
 240                 if (i >= 0)
 241                     return i;
 242             }
 243         }
 244         return 0;
 245         break;
 246     case '+':
 247         if (curpm) {
 248             paren = curpm->op_pmregexp->lastparen;
 249             if (!paren)
 250                 return 0;
 251             goto getparen;
 252         }
 253         return 0;
 254         break;
 255     case '`':
 256         if (curpm) {
 257             if (curpm->op_pmregexp &&
 258               (s = curpm->op_pmregexp->subbeg) ) {
 259                 i = curpm->op_pmregexp->startp[0] - s;
 260                 if (i >= 0)
 261                     return i;
 262             }
 263         }
 264         return 0;
 265     case '\'':
 266         if (curpm) {
 267             if (curpm->op_pmregexp &&
 268               (s = curpm->op_pmregexp->endp[0]) ) {
 269                 return (STRLEN) (curpm->op_pmregexp->subend - s);
 270             }
 271         }
 272         return 0;
 273     case ',':
 274         return (STRLEN)ofslen;
 275     case '\\':
 276         return (STRLEN)orslen;
 277     }
 278     magic_get(sv,mg);
 279     if (!SvPOK(sv) && SvNIOK(sv))
 280         sv_2pv(sv, &na);
 281     if (SvPOK(sv))
 282         return SvCUR(sv);
 283     return 0;
 284 }
 285
 286 int
 287 magic_get(sv, mg)
 288 SV *sv;
 289 MAGIC *mg;
 290 {
 291     register I32 paren;
 292     register char *s;
 293     register I32 i;
 294     char *t;
 295
 296     switch (*mg->mg_ptr) {
 297     case '\001':                /* ^A */
 298         sv_setsv(sv, bodytarget);
 299         break;
 300     case '\004':                /* ^D */
 301         sv_setiv(sv,(I32)(debug & 32767));
 302         break;
 303     case '\006':                /* ^F */
 304         sv_setiv(sv,(I32)maxsysfd);
 305         break;
 306     case '\010':                /* ^H */
 307         sv_setiv(sv,(I32)hints);
 308         break;
 309     case '\t':                  /* ^I */
 310         if (inplace)
 311             sv_setpv(sv, inplace);
 312         else
 313             sv_setsv(sv,&sv_undef);
 314         break;
 315     case '\020':                /* ^P */
 316         sv_setiv(sv,(I32)perldb);
 317         break;
 318     case '\024':                /* ^T */
 319         sv_setiv(sv,(I32)basetime);
 320         break;
 321     case '\027':                /* ^W */
 322         sv_setiv(sv,(I32)dowarn);
 323         break;
 324     case '1': case '2': case '3': case '4':
 325     case '5': case '6': case '7': case '8': case '9': case '&':
 326         if (curpm) {
 327             paren = atoi(GvENAME(mg->mg_obj));
 328           getparen:
 329             if (curpm->op_pmregexp &&
 330               paren <= curpm->op_pmregexp->nparens &&
 331               (s = curpm->op_pmregexp->startp[paren]) &&
 332               (t = curpm->op_pmregexp->endp[paren]) ) {
 333                 i = t - s;
 334                 if (i >= 0) {
 335                     MAGIC *tmg;
 336                     sv_setpvn(sv,s,i);
 337                     if (tainting && (tmg = mg_find(sv,'t')))
 338                         tmg->mg_len = 0;        /* guarantee $1 untainted */
 339                     break;
 340                 }
 341             }
 342         }
 343         sv_setsv(sv,&sv_undef);
 344         break;
 345     case '+':
 346         if (curpm) {
 347             paren = curpm->op_pmregexp->lastparen;
 348             if (paren)
 349                 goto getparen;
 350         }
 351         sv_setsv(sv,&sv_undef);
 352         break;
 353     case '`':
 354         if (curpm) {
 355             if (curpm->op_pmregexp &&
 356               (s = curpm->op_pmregexp->subbeg) ) {
 357                 i = curpm->op_pmregexp->startp[0] - s;
 358                 if (i >= 0) {
 359                     sv_setpvn(sv,s,i);
 360                     break;
 361                 }
 362             }
 363         }
 364         sv_setsv(sv,&sv_undef);
 365         break;
 366     case '\'':
 367         if (curpm) {
 368             if (curpm->op_pmregexp &&
 369               (s = curpm->op_pmregexp->endp[0]) ) {
 370                 sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
 371                 break;
 372             }
 373         }
 374         sv_setsv(sv,&sv_undef);
 375         break;
 376     case '.':
 377 #ifndef lint
 378         if (GvIO(last_in_gv)) {
 379             sv_setiv(sv,(I32)IoLINES(GvIO(last_in_gv)));
 380         }
 381 #endif
 382         break;
 383     case '?':
 384         sv_setiv(sv,(I32)statusvalue);
 385         break;
 386     case '^':
 387         s = IoTOP_NAME(GvIOp(defoutgv));
 388         if (s)
 389             sv_setpv(sv,s);
 390         else {
 391             sv_setpv(sv,GvENAME(defoutgv));
 392             sv_catpv(sv,"_TOP");
 393         }
 394         break;
 395     case '~':
 396         s = IoFMT_NAME(GvIOp(defoutgv));
 397         if (!s)
 398             s = GvENAME(defoutgv);
 399         sv_setpv(sv,s);
 400         break;
 401 #ifndef lint
 402     case '=':
 403         sv_setiv(sv,(I32)IoPAGE_LEN(GvIOp(defoutgv)));
 404         break;
 405     case '-':
 406         sv_setiv(sv,(I32)IoLINES_LEFT(GvIOp(defoutgv)));
 407         break;
 408     case '%':
 409         sv_setiv(sv,(I32)IoPAGE(GvIOp(defoutgv)));
 410         break;
 411 #endif
 412     case ':':
 413         break;
 414     case '/':
 415         break;
 416     case '[':
 417         sv_setiv(sv,(I32)curcop->cop_arybase);
 418         break;
 419     case '|':
 420         sv_setiv(sv, (IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
 421         break;
 422     case ',':
 423         sv_setpvn(sv,ofs,ofslen);
 424         break;
 425     case '\\':
 426         sv_setpvn(sv,ors,orslen);
 427         break;
 428     case '#':
 429         sv_setpv(sv,ofmt);
 430         break;
 431     case '!':
 432         sv_setnv(sv,(double)errno);
 433         sv_setpv(sv, errno ? Strerror(errno) : "");
 434         SvNOK_on(sv);   /* what a wonderful hack! */
 435         break;
 436     case '<':
 437         sv_setiv(sv,(I32)uid);
 438         break;
 439     case '>':
 440         sv_setiv(sv,(I32)euid);
 441         break;
 442     case '(':
 443         s = buf;
 444         (void)sprintf(s,"%d",(int)gid);
 445         goto add_groups;
 446     case ')':
 447         s = buf;
 448         (void)sprintf(s,"%d",(int)egid);
 449       add_groups:
 450         while (*s) s++;
 451 #ifdef HAS_GETGROUPS
 452 #ifndef NGROUPS
 453 #define NGROUPS 32
 454 #endif
 455         {
 456             Groups_t gary[NGROUPS];
 457
 458             i = getgroups(NGROUPS,gary);
 459             while (--i >= 0) {
 460                 (void)sprintf(s," %ld", (long)gary[i]);
 461                 while (*s) s++;
 462             }
 463         }
 464 #endif
 465         sv_setpv(sv,buf);
 466         break;
 467     case '*':
 468         break;
 469     case '0':
 470         break;
 471     }
 472     return 0;
 473 }
 474
 475 int
 476 magic_getuvar(sv, mg)
 477 SV *sv;
 478 MAGIC *mg;
 479 {
 480     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
 481
 482     if (uf && uf->uf_val)
 483         (*uf->uf_val)(uf->uf_index, sv);
 484     return 0;
 485 }
 486
 487 int
 488 magic_setenv(sv,mg)
 489 SV* sv;
 490 MAGIC* mg;
 491 {
 492     register char *s;
 493     STRLEN len;
 494     I32 i;
 495     s = SvPV(sv,len);
 496     my_setenv(mg->mg_ptr,s);
 497 #ifdef DYNAMIC_ENV_FETCH
 498      /* We just undefd an environment var.  Is a replacement */
 499      /* waiting in the wings? */
 500     if (!len) {
 501         SV **envsvp;
 502         if (envsvp = hv_fetch(GvHVn(envgv),mg->mg_ptr,mg->mg_len,FALSE))
 503             s = SvPV(*envsvp,len);
 504     }
 505 #endif
 506                             /* And you'll never guess what the dog had */
 507                             /*   in its mouth... */
 508     if (tainting) {
 509         if (s && strEQ(mg->mg_ptr,"PATH")) {
 510             char *strend = s + len;
 511
 512             while (s < strend) {
 513                 s = cpytill(tokenbuf,s,strend,':',&i);
 514                 s++;
 515                 if (*tokenbuf != '/'
 516                   || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
 517                     MgTAINTEDDIR_on(mg);
 518             }
 519         }
 520     }
 521     return 0;
 522 }
 523
 524 int
 525 magic_clearenv(sv,mg)
 526 SV* sv;
 527 MAGIC* mg;
 528 {
 529     my_setenv(mg->mg_ptr,Nullch);
 530     return 0;
 531 }
 532
 533 int
 534 magic_setsig(sv,mg)
 535 SV* sv;
 536 MAGIC* mg;
 537 {
 538     register char *s;
 539     I32 i;
 540     SV** svp;
 541
 542     s = mg->mg_ptr;
 543     if (*s == '_') {
 544         if (strEQ(s,"__DIE__"))
 545             svp = &diehook;
 546         else if (strEQ(s,"__WARN__"))
 547             svp = &warnhook;
 548         else if (strEQ(s,"__PARSE__"))
 549             svp = &parsehook;
 550         else
 551             croak("No such hook: %s", s);
 552         i = 0;
 553     }
 554     else {
 555         i = whichsig(s);        /* ...no, a brick */
 556         if (!i) {
 557             if (dowarn || strEQ(s,"ALARM"))
 558                 warn("No such signal: SIG%s", s);
 559             return 0;
 560         }
 561     }
 562     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
 563         if (i)
 564             (void)signal(i,sighandler);
 565         else
 566             *svp = SvREFCNT_inc(sv);
 567         return 0;
 568     }
 569     s = SvPV_force(sv,na);
 570     if (strEQ(s,"IGNORE")) {
 571         if (i)
 572             (void)signal(i,SIG_IGN);
 573         else
 574             *svp = 0;
 575     }
 576     else if (strEQ(s,"DEFAULT") || !*s) {
 577         if (i)
 578             (void)signal(i,SIG_DFL);
 579         else
 580             *svp = 0;
 581     }
 582     else {
 583         if (!strchr(s,':') && !strchr(s,'\'')) {
 584             sprintf(tokenbuf, "main::%s",s);
 585             sv_setpv(sv,tokenbuf);
 586         }
 587         if (i)
 588             (void)signal(i,sighandler);
 589         else
 590             *svp = SvREFCNT_inc(sv);
 591     }
 592     return 0;
 593 }
 594
 595 int
 596 magic_setisa(sv,mg)
 597 SV* sv;
 598 MAGIC* mg;
 599 {
 600     sub_generation++;
 601     return 0;
 602 }
 603
 604 #ifdef OVERLOAD
 605
 606 int
 607 magic_setamagic(sv,mg)
 608 SV* sv;
 609 MAGIC* mg;
 610 {
 611     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
 612     amagic_generation++;
 613
 614     return 0;
 615 }
 616 #endif /* OVERLOAD */
 617
 618 static int
 619 magic_methpack(sv,mg,meth)
 620 SV* sv;
 621 MAGIC* mg;
 622 char *meth;
 623 {
 624     dSP;
 625
 626     ENTER;
 627     SAVETMPS;
 628     PUSHMARK(sp);
 629     EXTEND(sp, 2);
 630     PUSHs(mg->mg_obj);
 631     if (mg->mg_ptr)
 632         PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
 633     else if (mg->mg_type == 'p')
 634         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
 635     PUTBACK;
 636
 637     if (perl_call_method(meth, G_SCALAR))
 638         sv_setsv(sv, *stack_sp--);
 639
 640     FREETMPS;
 641     LEAVE;
 642     return 0;
 643 }
 644
 645 int
 646 magic_getpack(sv,mg)
 647 SV* sv;
 648 MAGIC* mg;
 649 {
 650     magic_methpack(sv,mg,"FETCH");
 651     if (mg->mg_ptr)
 652         mg->mg_flags |= MGf_GSKIP;
 653     return 0;
 654 }
 655
 656 int
 657 magic_setpack(sv,mg)
 658 SV* sv;
 659 MAGIC* mg;
 660 {
 661     dSP;
 662
 663     PUSHMARK(sp);
 664     EXTEND(sp, 3);
 665     PUSHs(mg->mg_obj);
 666     if (mg->mg_ptr)
 667         PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
 668     else if (mg->mg_type == 'p')
 669         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
 670     PUSHs(sv);
 671     PUTBACK;
 672
 673     perl_call_method("STORE", G_SCALAR|G_DISCARD);
 674
 675     return 0;
 676 }
 677
 678 int
 679 magic_clearpack(sv,mg)
 680 SV* sv;
 681 MAGIC* mg;
 682 {
 683     return magic_methpack(sv,mg,"DELETE");
 684 }
 685
 686 int magic_wipepack(sv,mg)
 687 SV* sv;
 688 MAGIC* mg;
 689 {
 690     dSP;
 691
 692     PUSHMARK(sp);
 693     XPUSHs(mg->mg_obj);
 694     PUTBACK;
 695
 696     perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
 697
 698     return 0;
 699 }
 700
 701 int
 702 magic_nextpack(sv,mg,key)
 703 SV* sv;
 704 MAGIC* mg;
 705 SV* key;
 706 {
 707     dSP;
 708     char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
 709
 710     ENTER;
 711     SAVETMPS;
 712     PUSHMARK(sp);
 713     EXTEND(sp, 2);
 714     PUSHs(mg->mg_obj);
 715     if (SvOK(key))
 716         PUSHs(key);
 717     PUTBACK;
 718
 719     if (perl_call_method(meth, G_SCALAR))
 720         sv_setsv(key, *stack_sp--);
 721
 722     FREETMPS;
 723     LEAVE;
 724     return 0;
 725 }
 726
 727 int
 728 magic_existspack(sv,mg)
 729 SV* sv;
 730 MAGIC* mg;
 731 {
 732     return magic_methpack(sv,mg,"EXISTS");
 733 }
 734
 735 int
 736 magic_setdbline(sv,mg)
 737 SV* sv;
 738 MAGIC* mg;
 739 {
 740     OP *o;
 741     I32 i;
 742     GV* gv;
 743     SV** svp;
 744
 745     gv = DBline;
 746     i = SvTRUE(sv);
 747     svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
 748     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
 749         o->op_private = i;
 750     else
 751         warn("Can't break at that line\n");
 752     return 0;
 753 }
 754
 755 int
 756 magic_getarylen(sv,mg)
 757 SV* sv;
 758 MAGIC* mg;
 759 {
 760     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
 761     return 0;
 762 }
 763
 764 int
 765 magic_setarylen(sv,mg)
 766 SV* sv;
 767 MAGIC* mg;
 768 {
 769     av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
 770     return 0;
 771 }
 772
 773 int
 774 magic_getpos(sv,mg)
 775 SV* sv;
 776 MAGIC* mg;
 777 {
 778     SV* lsv = LvTARG(sv);
 779
 780     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
 781         mg = mg_find(lsv, 'g');
 782         if (mg && mg->mg_len >= 0) {
 783             sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
 784             return 0;
 785         }
 786     }
 787     (void)SvOK_off(sv);
 788     return 0;
 789 }
 790
 791 int
 792 magic_setpos(sv,mg)
 793 SV* sv;
 794 MAGIC* mg;
 795 {
 796     SV* lsv = LvTARG(sv);
 797     SSize_t pos;
 798     STRLEN len;
 799
 800     mg = 0;
 801
 802     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
 803         mg = mg_find(lsv, 'g');
 804     if (!mg) {
 805         if (!SvOK(sv))
 806             return 0;
 807         sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
 808         mg = mg_find(lsv, 'g');
 809     }
 810     else if (!SvOK(sv)) {
 811         mg->mg_len = -1;
 812         return 0;
 813     }
 814     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
 815
 816     pos = SvIV(sv) - curcop->cop_arybase;
 817     if (pos < 0) {
 818         pos += len;
 819         if (pos < 0)
 820             pos = 0;
 821     }
 822     else if (pos > len)
 823         pos = len;
 824     mg->mg_len = pos;
 825
 826     return 0;
 827 }
 828
 829 int
 830 magic_getglob(sv,mg)
 831 SV* sv;
 832 MAGIC* mg;
 833 {
 834     gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
 835     return 0;
 836 }
 837
 838 int
 839 magic_setglob(sv,mg)
 840 SV* sv;
 841 MAGIC* mg;
 842 {
 843     register char *s;
 844     GV* gv;
 845
 846     if (!SvOK(sv))
 847         return 0;
 848     s = SvPV(sv, na);
 849     if (*s == '*' && s[1])
 850         s++;
 851     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
 852     if (sv == (SV*)gv)
 853         return 0;
 854     if (GvGP(sv))
 855         gp_free(sv);
 856     GvGP(sv) = gp_ref(GvGP(gv));
 857     if (!GvAV(gv))
 858         gv_AVadd(gv);
 859     if (!GvHV(gv))
 860         gv_HVadd(gv);
 861     if (!GvIOp(gv))
 862         GvIOp(gv) = newIO();
 863     return 0;
 864 }
 865
 866 int
 867 magic_setsubstr(sv,mg)
 868 SV* sv;
 869 MAGIC* mg;
 870 {
 871     STRLEN len;
 872     char *tmps = SvPV(sv,len);
 873     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
 874     return 0;
 875 }
 876
 877 int
 878 magic_gettaint(sv,mg)
 879 SV* sv;
 880 MAGIC* mg;
 881 {
 882     if (mg->mg_len & 1)
 883         tainted = TRUE;
 884     else if (mg->mg_len & 2 && mg->mg_obj == sv)        /* kludge */
 885         tainted = TRUE;
 886     return 0;
 887 }
 888
 889 int
 890 magic_settaint(sv,mg)
 891 SV* sv;
 892 MAGIC* mg;
 893 {
 894     if (localizing) {
 895         if (localizing == 1)
 896             mg->mg_len <<= 1;
 897         else
 898             mg->mg_len >>= 1;
 899     }
 900     else if (tainted)
 901         mg->mg_len |= 1;
 902     else
 903         mg->mg_len &= ~1;
 904     return 0;
 905 }
 906
 907 int
 908 magic_setvec(sv,mg)
 909 SV* sv;
 910 MAGIC* mg;
 911 {
 912     do_vecset(sv);      /* XXX slurp this routine */
 913     return 0;
 914 }
 915
 916 int
 917 magic_setmglob(sv,mg)
 918 SV* sv;
 919 MAGIC* mg;
 920 {
 921     mg->mg_len = -1;
 922     return 0;
 923 }
 924
 925 int
 926 magic_setbm(sv,mg)
 927 SV* sv;
 928 MAGIC* mg;
 929 {
 930     sv_unmagic(sv, 'B');
 931     SvVALID_off(sv);
 932     return 0;
 933 }
 934
 935 int
 936 magic_setuvar(sv,mg)
 937 SV* sv;
 938 MAGIC* mg;
 939 {
 940     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
 941
 942     if (uf && uf->uf_set)
 943         (*uf->uf_set)(uf->uf_index, sv);
 944     return 0;
 945 }
 946
 947 int
 948 magic_set(sv,mg)
 949 SV* sv;
 950 MAGIC* mg;
 951 {
 952     register char *s;
 953     I32 i;
 954     STRLEN len;
 955     switch (*mg->mg_ptr) {
 956     case '\001':        /* ^A */
 957         sv_setsv(bodytarget, sv);
 958         break;
 959     case '\004':        /* ^D */
 960         debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
 961         DEBUG_x(dump_all());
 962         break;
 963     case '\006':        /* ^F */
 964         maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
 965         break;
 966     case '\010':        /* ^H */
 967         hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
 968         break;
 969     case '\t':  /* ^I */
 970         if (inplace)
 971             Safefree(inplace);
 972         if (SvOK(sv))
 973             inplace = savepv(SvPV(sv,na));
 974         else
 975             inplace = Nullch;
 976         break;
 977     case '\020':        /* ^P */
 978         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
 979         if (i != perldb) {
 980             if (perldb)
 981                 oldlastpm = curpm;
 982             else
 983                 curpm = oldlastpm;
 984         }
 985         perldb = i;
 986         break;
 987     case '\024':        /* ^T */
 988         basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 989         break;
 990     case '\027':        /* ^W */
 991         dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 992         break;
 993     case '.':
 994         if (localizing) {
 995             if (localizing == 1)
 996                 save_sptr((SV**)&last_in_gv);
 997         }
 998         else if (SvOK(sv))
 999             IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
1000         break;
1001     case '^':
1002         Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1003         IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1004         IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1005         break;
1006     case '~':
1007         Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1008         IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1009         IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1010         break;
1011     case '=':
1012         IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1013         break;
1014     case '-':
1015         IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1016         if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1017             IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
1018         break;
1019     case '%':
1020         IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1021         break;
1022     case '|':
1023         IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
1024         if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
1025             IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
1026         }
1027         break;
1028     case '*':
1029         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1030         multiline = (i != 0);
1031         break;
1032     case '/':
1033         if (SvOK(sv)) {
1034             nrs = rs = SvPV_force(sv,rslen);
1035             nrslen = rslen;
1036             if (rspara = !rslen) {
1037                 nrs = rs = "\n\n";
1038                 nrslen = rslen = 2;
1039             }
1040             nrschar = rschar = rs[rslen - 1];
1041         }
1042         else {
1043             nrschar = rschar = 0777;    /* fake a non-existent char */
1044             nrslen = rslen = 1;
1045         }
1046         break;
1047     case '\\':
1048         if (ors)
1049             Safefree(ors);
1050         ors = savepv(SvPV(sv,orslen));
1051         break;
1052     case ',':
1053         if (ofs)
1054             Safefree(ofs);
1055         ofs = savepv(SvPV(sv, ofslen));
1056         break;
1057     case '#':
1058         if (ofmt)
1059             Safefree(ofmt);
1060         ofmt = savepv(SvPV(sv,na));
1061         break;
1062     case '[':
1063         compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1064         break;
1065     case '?':
1066         statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1067         break;
1068     case '!':
1069         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SS$_ABORT);         /* will anyone ever use this? */
1070         break;
1071     case '<':
1072         uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1073         if (delaymagic) {
1074             delaymagic |= DM_RUID;
1075             break;                              /* don't do magic till later */
1076         }
1077 #ifdef HAS_SETRUID
1078         (void)setruid((Uid_t)uid);
1079 #else
1080 #ifdef HAS_SETREUID
1081         (void)setreuid((Uid_t)uid, (Uid_t)-1);
1082 #else
1083 #ifdef HAS_SETRESUID
1084       (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
1085 #else
1086         if (uid == euid)                /* special case $< = $> */
1087             (void)setuid(uid);
1088         else {
1089             uid = (I32)getuid();
1090             croak("setruid() not implemented");
1091         }
1092 #endif
1093 #endif
1094 #endif
1095         uid = (I32)getuid();
1096         tainting |= (euid != uid || egid != gid);
1097         break;
1098     case '>':
1099         euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1100         if (delaymagic) {
1101             delaymagic |= DM_EUID;
1102             break;                              /* don't do magic till later */
1103         }
1104 #ifdef HAS_SETEUID
1105         (void)seteuid((Uid_t)euid);
1106 #else
1107 #ifdef HAS_SETREUID
1108         (void)setreuid((Uid_t)-1, (Uid_t)euid);
1109 #else
1110 #ifdef HAS_SETRESUID
1111         (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
1112 #else
1113         if (euid == uid)                /* special case $> = $< */
1114             setuid(euid);
1115         else {
1116             euid = (I32)geteuid();
1117             croak("seteuid() not implemented");
1118         }
1119 #endif
1120 #endif
1121 #endif
1122         euid = (I32)geteuid();
1123         tainting |= (euid != uid || egid != gid);
1124         break;
1125     case '(':
1126         gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1127         if (delaymagic) {
1128             delaymagic |= DM_RGID;
1129             break;                              /* don't do magic till later */
1130         }
1131 #ifdef HAS_SETRGID
1132         (void)setrgid((Gid_t)gid);
1133 #else
1134 #ifdef HAS_SETREGID
1135         (void)setregid((Gid_t)gid, (Gid_t)-1);
1136 #else
1137 #ifdef HAS_SETRESGID
1138       (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
1139 #else
1140         if (gid == egid)                        /* special case $( = $) */
1141             (void)setgid(gid);
1142         else {
1143             gid = (I32)getgid();
1144             croak("setrgid() not implemented");
1145         }
1146 #endif
1147 #endif
1148 #endif
1149         gid = (I32)getgid();
1150         tainting |= (euid != uid || egid != gid);
1151         break;
1152     case ')':
1153         egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1154         if (delaymagic) {
1155             delaymagic |= DM_EGID;
1156             break;                              /* don't do magic till later */
1157         }
1158 #ifdef HAS_SETEGID
1159         (void)setegid((Gid_t)egid);
1160 #else
1161 #ifdef HAS_SETREGID
1162         (void)setregid((Gid_t)-1, (Gid_t)egid);
1163 #else
1164 #ifdef HAS_SETRESGID
1165         (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
1166 #else
1167         if (egid == gid)                        /* special case $) = $( */
1168             (void)setgid(egid);
1169         else {
1170             egid = (I32)getegid();
1171             croak("setegid() not implemented");
1172         }
1173 #endif
1174 #endif
1175 #endif
1176         egid = (I32)getegid();
1177         tainting |= (euid != uid || egid != gid);
1178         break;
1179     case ':':
1180         chopset = SvPV_force(sv,na);
1181         break;
1182     case '0':
1183         if (!origalen) {
1184             s = origargv[0];
1185             s += strlen(s);
1186             /* See if all the arguments are contiguous in memory */
1187             for (i = 1; i < origargc; i++) {
1188                 if (origargv[i] == s + 1)
1189                     s += strlen(++s);   /* this one is ok too */
1190             }
1191             if (origenviron[0] == s + 1) {      /* can grab env area too? */
1192                 my_setenv("NoNeSuCh", Nullch);
1193                                             /* force copy of environment */
1194                 for (i = 0; origenviron[i]; i++)
1195                     if (origenviron[i] == s + 1)
1196                         s += strlen(++s);
1197             }
1198             origalen = s - origargv[0];
1199         }
1200         s = SvPV_force(sv,len);
1201         i = len;
1202         if (i >= origalen) {
1203             i = origalen;
1204             SvCUR_set(sv, i);
1205             *SvEND(sv) = '\0';
1206             Copy(s, origargv[0], i, char);
1207         }
1208         else {
1209             Copy(s, origargv[0], i, char);
1210             s = origargv[0]+i;
1211             *s++ = '\0';
1212             while (++i < origalen)
1213                 *s++ = ' ';
1214             s = origargv[0]+i;
1215             for (i = 1; i < origargc; i++)
1216                 origargv[i] = Nullch;
1217         }
1218         break;
1219     }
1220     return 0;
1221 }
1222
1223 I32
1224 whichsig(sig)
1225 char *sig;
1226 {
1227     register char **sigv;
1228
1229     for (sigv = sig_name+1; *sigv; sigv++)
1230         if (strEQ(sig,*sigv))
1231             return sig_num[sigv - sig_name];
1232 #ifdef SIGCLD
1233     if (strEQ(sig,"CHLD"))
1234         return SIGCLD;
1235 #endif
1236 #ifdef SIGCHLD
1237     if (strEQ(sig,"CLD"))
1238         return SIGCHLD;
1239 #endif
1240     return 0;
1241 }
1242
1243 char *
1244 whichsigname(sig)
1245 int sig;
1246 {
1247     register int i;
1248     for (i = 1; sig_num[i]; i++)  /* sig_num[] is a 0-terminated list */
1249         if (sig_num[i] == sig)
1250             return sig_name[i];
1251     return Nullch;
1252 }
1253
1254 Signal_t
1255 sighandler(sig)
1256 int sig;
1257 {
1258     dSP;
1259     GV *gv;
1260     HV *st;
1261     SV *sv;
1262     CV *cv;
1263     AV *oldstack;
1264     char *signame;
1265
1266 #ifdef OS2              /* or anybody else who requires SIG_ACK */
1267     signal(sig, SIG_ACK);
1268 #endif
1269
1270     signame = whichsigname(sig);
1271     cv = sv_2cv(*hv_fetch(GvHVn(siggv),signame,strlen(signame),
1272                           TRUE),
1273                 &st, &gv, TRUE);
1274     if (!cv || !CvROOT(cv) &&
1275         *signame == 'C' && instr(signame,"LD")) {
1276
1277         if (signame[1] == 'H')
1278             cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE),
1279                         &st, &gv, TRUE);
1280         else
1281             cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE),
1282                         &st, &gv, TRUE);
1283         /* gag */
1284     }
1285     if (!cv || !CvROOT(cv)) {
1286         if (dowarn)
1287             warn("SIG%s handler \"%s\" not defined.\n",
1288                 signame, GvENAME(gv) );
1289         return;
1290     }
1291
1292     oldstack = stack;
1293     if (stack != signalstack)
1294         AvFILL(signalstack) = 0;
1295     SWITCHSTACK(stack, signalstack);
1296
1297     sv = sv_newmortal();
1298     sv_setpv(sv,signame);
1299     PUSHMARK(sp);
1300     PUSHs(sv);
1301     PUTBACK;
1302
1303     perl_call_sv((SV*)cv, G_DISCARD);
1304
1305     SWITCHSTACK(signalstack, oldstack);
1306
1307     return;
1308 }