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