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