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