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