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