mg.c

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