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