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 int
 535 magic_setsig(sv,mg)
 536 SV* sv;
 537 MAGIC* mg;
 538 {
 539     register char *s;
 540     I32 i;
 541     SV** svp;
 542
 543     s = mg->mg_ptr;
 544     if (*s == '_') {
 545         if (strEQ(s,"__DIE__"))
 546             svp = &diehook;
 547         else if (strEQ(s,"__WARN__"))
 548             svp = &warnhook;
 549         else if (strEQ(s,"__PARSE__"))
 550             svp = &parsehook;
 551         else
 552             croak("No such hook: %s", s);
 553         i = 0;
 554         if (*svp) {
 555             SvREFCNT_dec(*svp);
 556             *svp = 0;
 557         }
 558     }
 559     else {
 560         i = whichsig(s);        /* ...no, a brick */
 561         if (!i) {
 562             if (dowarn || strEQ(s,"ALARM"))
 563                 warn("No such signal: SIG%s", s);
 564             return 0;
 565         }
 566     }
 567     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
 568         if (i)
 569             (void)signal(i,sighandler);
 570         else
 571             *svp = SvREFCNT_inc(sv);
 572         return 0;
 573     }
 574     s = SvPV_force(sv,na);
 575     if (strEQ(s,"IGNORE")) {
 576         if (i)
 577             (void)signal(i,SIG_IGN);
 578         else
 579             *svp = 0;
 580     }
 581     else if (strEQ(s,"DEFAULT") || !*s) {
 582         if (i)
 583             (void)signal(i,SIG_DFL);
 584         else
 585             *svp = 0;
 586     }
 587     else {
 588         if (!strchr(s,':') && !strchr(s,'\'')) {
 589             sprintf(tokenbuf, "main::%s",s);
 590             sv_setpv(sv,tokenbuf);
 591         }
 592         if (i)
 593             (void)signal(i,sighandler);
 594         else
 595             *svp = SvREFCNT_inc(sv);
 596     }
 597     return 0;
 598 }
 599
 600 int
 601 magic_setisa(sv,mg)
 602 SV* sv;
 603 MAGIC* mg;
 604 {
 605     sub_generation++;
 606     return 0;
 607 }
 608
 609 #ifdef OVERLOAD
 610
 611 int
 612 magic_setamagic(sv,mg)
 613 SV* sv;
 614 MAGIC* mg;
 615 {
 616     /* HV_badAMAGIC_on(Sv_STASH(sv)); */
 617     amagic_generation++;
 618
 619     return 0;
 620 }
 621 #endif /* OVERLOAD */
 622
 623 static int
 624 magic_methpack(sv,mg,meth)
 625 SV* sv;
 626 MAGIC* mg;
 627 char *meth;
 628 {
 629     dSP;
 630
 631     ENTER;
 632     SAVETMPS;
 633     PUSHMARK(sp);
 634     EXTEND(sp, 2);
 635     PUSHs(mg->mg_obj);
 636     if (mg->mg_ptr)
 637         PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
 638     else if (mg->mg_type == 'p')
 639         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
 640     PUTBACK;
 641
 642     if (perl_call_method(meth, G_SCALAR))
 643         sv_setsv(sv, *stack_sp--);
 644
 645     FREETMPS;
 646     LEAVE;
 647     return 0;
 648 }
 649
 650 int
 651 magic_getpack(sv,mg)
 652 SV* sv;
 653 MAGIC* mg;
 654 {
 655     magic_methpack(sv,mg,"FETCH");
 656     if (mg->mg_ptr)
 657         mg->mg_flags |= MGf_GSKIP;
 658     return 0;
 659 }
 660
 661 int
 662 magic_setpack(sv,mg)
 663 SV* sv;
 664 MAGIC* mg;
 665 {
 666     dSP;
 667
 668     PUSHMARK(sp);
 669     EXTEND(sp, 3);
 670     PUSHs(mg->mg_obj);
 671     if (mg->mg_ptr)
 672         PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
 673     else if (mg->mg_type == 'p')
 674         PUSHs(sv_2mortal(newSViv(mg->mg_len)));
 675     PUSHs(sv);
 676     PUTBACK;
 677
 678     perl_call_method("STORE", G_SCALAR|G_DISCARD);
 679
 680     return 0;
 681 }
 682
 683 int
 684 magic_clearpack(sv,mg)
 685 SV* sv;
 686 MAGIC* mg;
 687 {
 688     return magic_methpack(sv,mg,"DELETE");
 689 }
 690
 691 int magic_wipepack(sv,mg)
 692 SV* sv;
 693 MAGIC* mg;
 694 {
 695     dSP;
 696
 697     PUSHMARK(sp);
 698     XPUSHs(mg->mg_obj);
 699     PUTBACK;
 700
 701     perl_call_method("CLEAR", G_SCALAR|G_DISCARD);
 702
 703     return 0;
 704 }
 705
 706 int
 707 magic_nextpack(sv,mg,key)
 708 SV* sv;
 709 MAGIC* mg;
 710 SV* key;
 711 {
 712     dSP;
 713     char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
 714
 715     ENTER;
 716     SAVETMPS;
 717     PUSHMARK(sp);
 718     EXTEND(sp, 2);
 719     PUSHs(mg->mg_obj);
 720     if (SvOK(key))
 721         PUSHs(key);
 722     PUTBACK;
 723
 724     if (perl_call_method(meth, G_SCALAR))
 725         sv_setsv(key, *stack_sp--);
 726
 727     FREETMPS;
 728     LEAVE;
 729     return 0;
 730 }
 731
 732 int
 733 magic_existspack(sv,mg)
 734 SV* sv;
 735 MAGIC* mg;
 736 {
 737     return magic_methpack(sv,mg,"EXISTS");
 738 }
 739
 740 int
 741 magic_setdbline(sv,mg)
 742 SV* sv;
 743 MAGIC* mg;
 744 {
 745     OP *o;
 746     I32 i;
 747     GV* gv;
 748     SV** svp;
 749
 750     gv = DBline;
 751     i = SvTRUE(sv);
 752     svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
 753     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
 754         o->op_private = i;
 755     else
 756         warn("Can't break at that line\n");
 757     return 0;
 758 }
 759
 760 int
 761 magic_getarylen(sv,mg)
 762 SV* sv;
 763 MAGIC* mg;
 764 {
 765     sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + curcop->cop_arybase);
 766     return 0;
 767 }
 768
 769 int
 770 magic_setarylen(sv,mg)
 771 SV* sv;
 772 MAGIC* mg;
 773 {
 774     av_fill((AV*)mg->mg_obj, SvIV(sv) - curcop->cop_arybase);
 775     return 0;
 776 }
 777
 778 int
 779 magic_getpos(sv,mg)
 780 SV* sv;
 781 MAGIC* mg;
 782 {
 783     SV* lsv = LvTARG(sv);
 784
 785     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
 786         mg = mg_find(lsv, 'g');
 787         if (mg && mg->mg_len >= 0) {
 788             sv_setiv(sv, mg->mg_len + curcop->cop_arybase);
 789             return 0;
 790         }
 791     }
 792     (void)SvOK_off(sv);
 793     return 0;
 794 }
 795
 796 int
 797 magic_setpos(sv,mg)
 798 SV* sv;
 799 MAGIC* mg;
 800 {
 801     SV* lsv = LvTARG(sv);
 802     SSize_t pos;
 803     STRLEN len;
 804
 805     mg = 0;
 806
 807     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
 808         mg = mg_find(lsv, 'g');
 809     if (!mg) {
 810         if (!SvOK(sv))
 811             return 0;
 812         sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
 813         mg = mg_find(lsv, 'g');
 814     }
 815     else if (!SvOK(sv)) {
 816         mg->mg_len = -1;
 817         return 0;
 818     }
 819     len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
 820
 821     pos = SvIV(sv) - curcop->cop_arybase;
 822     if (pos < 0) {
 823         pos += len;
 824         if (pos < 0)
 825             pos = 0;
 826     }
 827     else if (pos > len)
 828         pos = len;
 829     mg->mg_len = pos;
 830
 831     return 0;
 832 }
 833
 834 int
 835 magic_getglob(sv,mg)
 836 SV* sv;
 837 MAGIC* mg;
 838 {
 839     gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
 840     return 0;
 841 }
 842
 843 int
 844 magic_setglob(sv,mg)
 845 SV* sv;
 846 MAGIC* mg;
 847 {
 848     register char *s;
 849     GV* gv;
 850
 851     if (!SvOK(sv))
 852         return 0;
 853     s = SvPV(sv, na);
 854     if (*s == '*' && s[1])
 855         s++;
 856     gv = gv_fetchpv(s,TRUE, SVt_PVGV);
 857     if (sv == (SV*)gv)
 858         return 0;
 859     if (GvGP(sv))
 860         gp_free(sv);
 861     GvGP(sv) = gp_ref(GvGP(gv));
 862     if (!GvAV(gv))
 863         gv_AVadd(gv);
 864     if (!GvHV(gv))
 865         gv_HVadd(gv);
 866     if (!GvIOp(gv))
 867         GvIOp(gv) = newIO();
 868     return 0;
 869 }
 870
 871 int
 872 magic_setsubstr(sv,mg)
 873 SV* sv;
 874 MAGIC* mg;
 875 {
 876     STRLEN len;
 877     char *tmps = SvPV(sv,len);
 878     sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
 879     return 0;
 880 }
 881
 882 int
 883 magic_gettaint(sv,mg)
 884 SV* sv;
 885 MAGIC* mg;
 886 {
 887     if (mg->mg_len & 1)
 888         tainted = TRUE;
 889     else if (mg->mg_len & 2 && mg->mg_obj == sv)        /* kludge */
 890         tainted = TRUE;
 891     return 0;
 892 }
 893
 894 int
 895 magic_settaint(sv,mg)
 896 SV* sv;
 897 MAGIC* mg;
 898 {
 899     if (localizing) {
 900         if (localizing == 1)
 901             mg->mg_len <<= 1;
 902         else
 903             mg->mg_len >>= 1;
 904     }
 905     else if (tainted)
 906         mg->mg_len |= 1;
 907     else
 908         mg->mg_len &= ~1;
 909     return 0;
 910 }
 911
 912 int
 913 magic_setvec(sv,mg)
 914 SV* sv;
 915 MAGIC* mg;
 916 {
 917     do_vecset(sv);      /* XXX slurp this routine */
 918     return 0;
 919 }
 920
 921 int
 922 magic_setmglob(sv,mg)
 923 SV* sv;
 924 MAGIC* mg;
 925 {
 926     mg->mg_len = -1;
 927     return 0;
 928 }
 929
 930 int
 931 magic_setbm(sv,mg)
 932 SV* sv;
 933 MAGIC* mg;
 934 {
 935     sv_unmagic(sv, 'B');
 936     SvVALID_off(sv);
 937     return 0;
 938 }
 939
 940 int
 941 magic_setuvar(sv,mg)
 942 SV* sv;
 943 MAGIC* mg;
 944 {
 945     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
 946
 947     if (uf && uf->uf_set)
 948         (*uf->uf_set)(uf->uf_index, sv);
 949     return 0;
 950 }
 951
 952 int
 953 magic_set(sv,mg)
 954 SV* sv;
 955 MAGIC* mg;
 956 {
 957     register char *s;
 958     I32 i;
 959     STRLEN len;
 960     switch (*mg->mg_ptr) {
 961     case '\001':        /* ^A */
 962         sv_setsv(bodytarget, sv);
 963         break;
 964     case '\004':        /* ^D */
 965         debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
 966         DEBUG_x(dump_all());
 967         break;
 968     case '\006':        /* ^F */
 969         maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
 970         break;
 971     case '\010':        /* ^H */
 972         hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
 973         break;
 974     case '\t':  /* ^I */
 975         if (inplace)
 976             Safefree(inplace);
 977         if (SvOK(sv))
 978             inplace = savepv(SvPV(sv,na));
 979         else
 980             inplace = Nullch;
 981         break;
 982     case '\020':        /* ^P */
 983         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
 984         if (i != perldb) {
 985             if (perldb)
 986                 oldlastpm = curpm;
 987             else
 988                 curpm = oldlastpm;
 989         }
 990         perldb = i;
 991         break;
 992     case '\024':        /* ^T */
 993         basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 994         break;
 995     case '\027':        /* ^W */
 996         dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 997         break;
 998     case '.':
 999         if (localizing) {
1000             if (localizing == 1)
1001                 save_sptr((SV**)&last_in_gv);
1002         }
1003         else if (SvOK(sv))
1004             IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
1005         break;
1006     case '^':
1007         Safefree(IoTOP_NAME(GvIOp(defoutgv)));
1008         IoTOP_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1009         IoTOP_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1010         break;
1011     case '~':
1012         Safefree(IoFMT_NAME(GvIOp(defoutgv)));
1013         IoFMT_NAME(GvIOp(defoutgv)) = s = savepv(SvPV(sv,na));
1014         IoFMT_GV(GvIOp(defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
1015         break;
1016     case '=':
1017         IoPAGE_LEN(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1018         break;
1019     case '-':
1020         IoLINES_LEFT(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1021         if (IoLINES_LEFT(GvIOp(defoutgv)) < 0L)
1022             IoLINES_LEFT(GvIOp(defoutgv)) = 0L;
1023         break;
1024     case '%':
1025         IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1026         break;
1027     case '|':
1028         IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
1029         if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
1030             IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
1031         }
1032         break;
1033     case '*':
1034         i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1035         multiline = (i != 0);
1036         break;
1037     case '/':
1038         if (SvOK(sv)) {
1039             nrs = rs = SvPV_force(sv,rslen);
1040             nrslen = rslen;
1041             if (rspara = !rslen) {
1042                 nrs = rs = "\n\n";
1043                 nrslen = rslen = 2;
1044             }
1045             nrschar = rschar = rs[rslen - 1];
1046         }
1047         else {
1048             nrschar = rschar = 0777;    /* fake a non-existent char */
1049             nrslen = rslen = 1;
1050         }
1051         break;
1052     case '\\':
1053         if (ors)
1054             Safefree(ors);
1055         ors = savepv(SvPV(sv,orslen));
1056         break;
1057     case ',':
1058         if (ofs)
1059             Safefree(ofs);
1060         ofs = savepv(SvPV(sv, ofslen));
1061         break;
1062     case '#':
1063         if (ofmt)
1064             Safefree(ofmt);
1065         ofmt = savepv(SvPV(sv,na));
1066         break;
1067     case '[':
1068         compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1069         break;
1070     case '?':
1071         statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
1072         break;
1073     case '!':
1074         SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),SS$_ABORT);         /* will anyone ever use this? */
1075         break;
1076     case '<':
1077         uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1078         if (delaymagic) {
1079             delaymagic |= DM_RUID;
1080             break;                              /* don't do magic till later */
1081         }
1082 #ifdef HAS_SETRUID
1083         (void)setruid((Uid_t)uid);
1084 #else
1085 #ifdef HAS_SETREUID
1086         (void)setreuid((Uid_t)uid, (Uid_t)-1);
1087 #else
1088 #ifdef HAS_SETRESUID
1089       (void)setresuid((Uid_t)uid, (Uid_t)-1, (Uid_t)-1);
1090 #else
1091         if (uid == euid)                /* special case $< = $> */
1092             (void)setuid(uid);
1093         else {
1094             uid = (I32)getuid();
1095             croak("setruid() not implemented");
1096         }
1097 #endif
1098 #endif
1099 #endif
1100         uid = (I32)getuid();
1101         tainting |= (uid && (euid != uid || egid != gid));
1102         break;
1103     case '>':
1104         euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1105         if (delaymagic) {
1106             delaymagic |= DM_EUID;
1107             break;                              /* don't do magic till later */
1108         }
1109 #ifdef HAS_SETEUID
1110         (void)seteuid((Uid_t)euid);
1111 #else
1112 #ifdef HAS_SETREUID
1113         (void)setreuid((Uid_t)-1, (Uid_t)euid);
1114 #else
1115 #ifdef HAS_SETRESUID
1116         (void)setresuid((Uid_t)-1, (Uid_t)euid, (Uid_t)-1);
1117 #else
1118         if (euid == uid)                /* special case $> = $< */
1119             setuid(euid);
1120         else {
1121             euid = (I32)geteuid();
1122             croak("seteuid() not implemented");
1123         }
1124 #endif
1125 #endif
1126 #endif
1127         euid = (I32)geteuid();
1128         tainting |= (uid && (euid != uid || egid != gid));
1129         break;
1130     case '(':
1131         gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1132         if (delaymagic) {
1133             delaymagic |= DM_RGID;
1134             break;                              /* don't do magic till later */
1135         }
1136 #ifdef HAS_SETRGID
1137         (void)setrgid((Gid_t)gid);
1138 #else
1139 #ifdef HAS_SETREGID
1140         (void)setregid((Gid_t)gid, (Gid_t)-1);
1141 #else
1142 #ifdef HAS_SETRESGID
1143       (void)setresgid((Gid_t)gid, (Gid_t)-1, (Gid_t) 1);
1144 #else
1145         if (gid == egid)                        /* special case $( = $) */
1146             (void)setgid(gid);
1147         else {
1148             gid = (I32)getgid();
1149             croak("setrgid() not implemented");
1150         }
1151 #endif
1152 #endif
1153 #endif
1154         gid = (I32)getgid();
1155         tainting |= (uid && (euid != uid || egid != gid));
1156         break;
1157     case ')':
1158         egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
1159         if (delaymagic) {
1160             delaymagic |= DM_EGID;
1161             break;                              /* don't do magic till later */
1162         }
1163 #ifdef HAS_SETEGID
1164         (void)setegid((Gid_t)egid);
1165 #else
1166 #ifdef HAS_SETREGID
1167         (void)setregid((Gid_t)-1, (Gid_t)egid);
1168 #else
1169 #ifdef HAS_SETRESGID
1170         (void)setresgid((Gid_t)-1, (Gid_t)egid, (Gid_t)-1);
1171 #else
1172         if (egid == gid)                        /* special case $) = $( */
1173             (void)setgid(egid);
1174         else {
1175             egid = (I32)getegid();
1176             croak("setegid() not implemented");
1177         }
1178 #endif
1179 #endif
1180 #endif
1181         egid = (I32)getegid();
1182         tainting |= (uid && (euid != uid || egid != gid));
1183         break;
1184     case ':':
1185         chopset = SvPV_force(sv,na);
1186         break;
1187     case '0':
1188         if (!origalen) {
1189             s = origargv[0];
1190             s += strlen(s);
1191             /* See if all the arguments are contiguous in memory */
1192             for (i = 1; i < origargc; i++) {
1193                 if (origargv[i] == s + 1)
1194                     s += strlen(++s);   /* this one is ok too */
1195             }
1196             if (origenviron[0] == s + 1) {      /* can grab env area too? */
1197                 my_setenv("NoNeSuCh", Nullch);
1198                                             /* force copy of environment */
1199                 for (i = 0; origenviron[i]; i++)
1200                     if (origenviron[i] == s + 1)
1201                         s += strlen(++s);
1202             }
1203             origalen = s - origargv[0];
1204         }
1205         s = SvPV_force(sv,len);
1206         i = len;
1207         if (i >= origalen) {
1208             i = origalen;
1209             SvCUR_set(sv, i);
1210             *SvEND(sv) = '\0';
1211             Copy(s, origargv[0], i, char);
1212         }
1213         else {
1214             Copy(s, origargv[0], i, char);
1215             s = origargv[0]+i;
1216             *s++ = '\0';
1217             while (++i < origalen)
1218                 *s++ = ' ';
1219             s = origargv[0]+i;
1220             for (i = 1; i < origargc; i++)
1221                 origargv[i] = Nullch;
1222         }
1223         break;
1224     }
1225     return 0;
1226 }
1227
1228 I32
1229 whichsig(sig)
1230 char *sig;
1231 {
1232     register char **sigv;
1233
1234     for (sigv = sig_name+1; *sigv; sigv++)
1235         if (strEQ(sig,*sigv))
1236             return sig_num[sigv - sig_name];
1237 #ifdef SIGCLD
1238     if (strEQ(sig,"CHLD"))
1239         return SIGCLD;
1240 #endif
1241 #ifdef SIGCHLD
1242     if (strEQ(sig,"CLD"))
1243         return SIGCHLD;
1244 #endif
1245     return 0;
1246 }
1247
1248 Signal_t
1249 sighandler(sig)
1250 int sig;
1251 {
1252     dSP;
1253     GV *gv;
1254     HV *st;
1255     SV *sv;
1256     CV *cv;
1257     AV *oldstack;
1258     char *signame;
1259
1260 #ifdef OS2              /* or anybody else who requires SIG_ACK */
1261     signal(sig, SIG_ACK);
1262 #endif
1263
1264     signame = sig_name[sig];
1265     cv = sv_2cv(*hv_fetch(GvHVn(siggv),signame,strlen(signame),
1266                           TRUE),
1267                 &st, &gv, TRUE);
1268     if (!cv || !CvROOT(cv) &&
1269         *signame == 'C' && instr(signame,"LD")) {
1270
1271         if (signame[1] == 'H')
1272             cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE),
1273                         &st, &gv, TRUE);
1274         else
1275             cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE),
1276                         &st, &gv, TRUE);
1277         /* gag */
1278     }
1279     if (!cv || !CvROOT(cv)) {
1280         if (dowarn)
1281             warn("SIG%s handler \"%s\" not defined.\n",
1282                 signame, GvENAME(gv) );
1283         return;
1284     }
1285
1286     oldstack = stack;
1287     if (stack != signalstack)
1288         AvFILL(signalstack) = 0;
1289     SWITCHSTACK(stack, signalstack);
1290
1291     sv = sv_newmortal();
1292     sv_setpv(sv,signame);
1293     PUSHMARK(sp);
1294     PUSHs(sv);
1295     PUTBACK;
1296
1297     perl_call_sv((SV*)cv, G_DISCARD);
1298
1299     SWITCHSTACK(signalstack, oldstack);
1300
1301     return;
1302 }