mg.c

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