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