stab.c

   1 /* $RCSfile: stab.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:35:33 $
   2  *
   3  *    Copyright (c) 1991, 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  * $Log:        stab.c,v $
   9  * Revision 4.0.1.3  91/11/05  18:35:33  lwall
  10  * patch11: length($x) was sometimes wrong for numeric $x
  11  * patch11: perl now issues warning if $SIG{'ALARM'} is referenced
  12  * patch11: *foo = undef coredumped
  13  * patch11: solitary subroutine references no longer trigger typo warnings
  14  * patch11: local(*FILEHANDLE) had a memory leak
  15  *
  16  * Revision 4.0.1.2  91/06/07  11:55:53  lwall
  17  * patch4: new copyright notice
  18  * patch4: added $^P variable to control calling of perldb routines
  19  * patch4: added $^F variable to specify maximum system fd, default 2
  20  * patch4: $` was busted inside s///
  21  * patch4: default top-of-form format is now FILEHANDLE_TOP
  22  * patch4: length($`), length($&), length($') now optimized to avoid string copy
  23  * patch4: $^D |= 1024 now does syntax tree dump at run-time
  24  *
  25  * Revision 4.0.1.1  91/04/12  09:10:24  lwall
  26  * patch1: Configure now differentiates getgroups() type from getgid() type
  27  * patch1: you may now use "die" and "caller" in a signal handler
  28  *
  29  * Revision 4.0  91/03/20  01:39:41  lwall
  30  * 4.0 baseline.
  31  *
  32  */
  33
  34 #include "EXTERN.h"
  35 #include "perl.h"
  36
  37 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  38 #include <signal.h>
  39 #endif
  40
  41 static char *sig_name[] = {
  42     SIG_NAME,0
  43 };
  44
  45 #ifdef VOIDSIG
  46 #define handlertype void
  47 #else
  48 #define handlertype int
  49 #endif
  50
  51 static handlertype sighandler();
  52
  53 static int origalen = 0;
  54
  55 STR *
  56 stab_str(str)
  57 STR *str;
  58 {
  59     STAB *stab = str->str_u.str_stab;
  60     register int paren;
  61     register char *s;
  62     register int i;
  63
  64     if (str->str_rare)
  65         return stab_val(stab);
  66
  67     switch (*stab->str_magic->str_ptr) {
  68     case '\004':                /* ^D */
  69 #ifdef DEBUGGING
  70         str_numset(stab_val(stab),(double)(debug & 32767));
  71 #endif
  72         break;
  73     case '\006':                /* ^F */
  74         str_numset(stab_val(stab),(double)maxsysfd);
  75         break;
  76     case '\t':                  /* ^I */
  77         if (inplace)
  78             str_set(stab_val(stab), inplace);
  79         else
  80             str_sset(stab_val(stab),&str_undef);
  81         break;
  82     case '\020':                /* ^P */
  83         str_numset(stab_val(stab),(double)perldb);
  84         break;
  85     case '\024':                /* ^T */
  86         str_numset(stab_val(stab),(double)basetime);
  87         break;
  88     case '\027':                /* ^W */
  89         str_numset(stab_val(stab),(double)dowarn);
  90         break;
  91     case '1': case '2': case '3': case '4':
  92     case '5': case '6': case '7': case '8': case '9': case '&':
  93         if (curspat) {
  94             paren = atoi(stab_name(stab));
  95           getparen:
  96             if (curspat->spat_regexp &&
  97               paren <= curspat->spat_regexp->nparens &&
  98               (s = curspat->spat_regexp->startp[paren]) ) {
  99                 i = curspat->spat_regexp->endp[paren] - s;
 100                 if (i >= 0)
 101                     str_nset(stab_val(stab),s,i);
 102                 else
 103                     str_sset(stab_val(stab),&str_undef);
 104             }
 105             else
 106                 str_sset(stab_val(stab),&str_undef);
 107         }
 108         break;
 109     case '+':
 110         if (curspat) {
 111             paren = curspat->spat_regexp->lastparen;
 112             goto getparen;
 113         }
 114         break;
 115     case '`':
 116         if (curspat) {
 117             if (curspat->spat_regexp &&
 118               (s = curspat->spat_regexp->subbeg) ) {
 119                 i = curspat->spat_regexp->startp[0] - s;
 120                 if (i >= 0)
 121                     str_nset(stab_val(stab),s,i);
 122                 else
 123                     str_nset(stab_val(stab),"",0);
 124             }
 125             else
 126                 str_nset(stab_val(stab),"",0);
 127         }
 128         break;
 129     case '\'':
 130         if (curspat) {
 131             if (curspat->spat_regexp &&
 132               (s = curspat->spat_regexp->endp[0]) ) {
 133                 str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s);
 134             }
 135             else
 136                 str_nset(stab_val(stab),"",0);
 137         }
 138         break;
 139     case '.':
 140 #ifndef lint
 141         if (last_in_stab) {
 142             str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
 143         }
 144 #endif
 145         break;
 146     case '?':
 147         str_numset(stab_val(stab),(double)statusvalue);
 148         break;
 149     case '^':
 150         s = stab_io(curoutstab)->top_name;
 151         if (s)
 152             str_set(stab_val(stab),s);
 153         else {
 154             str_set(stab_val(stab),stab_name(curoutstab));
 155             str_cat(stab_val(stab),"_TOP");
 156         }
 157         break;
 158     case '~':
 159         s = stab_io(curoutstab)->fmt_name;
 160         if (!s)
 161             s = stab_name(curoutstab);
 162         str_set(stab_val(stab),s);
 163         break;
 164 #ifndef lint
 165     case '=':
 166         str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
 167         break;
 168     case '-':
 169         str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
 170         break;
 171     case '%':
 172         str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
 173         break;
 174 #endif
 175     case '/':
 176         break;
 177     case '[':
 178         str_numset(stab_val(stab),(double)arybase);
 179         break;
 180     case '|':
 181         if (!stab_io(curoutstab))
 182             stab_io(curoutstab) = stio_new();
 183         str_numset(stab_val(stab),
 184            (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
 185         break;
 186     case ',':
 187         str_nset(stab_val(stab),ofs,ofslen);
 188         break;
 189     case '\\':
 190         str_nset(stab_val(stab),ors,orslen);
 191         break;
 192     case '#':
 193         str_set(stab_val(stab),ofmt);
 194         break;
 195     case '!':
 196         str_numset(stab_val(stab), (double)errno);
 197         str_set(stab_val(stab), errno ? strerror(errno) : "");
 198         stab_val(stab)->str_nok = 1;    /* what a wonderful hack! */
 199         break;
 200     case '<':
 201         str_numset(stab_val(stab),(double)uid);
 202         break;
 203     case '>':
 204         str_numset(stab_val(stab),(double)euid);
 205         break;
 206     case '(':
 207         s = buf;
 208         (void)sprintf(s,"%d",(int)gid);
 209         goto add_groups;
 210     case ')':
 211         s = buf;
 212         (void)sprintf(s,"%d",(int)egid);
 213       add_groups:
 214         while (*s) s++;
 215 #ifdef HAS_GETGROUPS
 216 #ifndef NGROUPS
 217 #define NGROUPS 32
 218 #endif
 219         {
 220             GROUPSTYPE gary[NGROUPS];
 221
 222             i = getgroups(NGROUPS,gary);
 223             while (--i >= 0) {
 224                 (void)sprintf(s," %ld", (long)gary[i]);
 225                 while (*s) s++;
 226             }
 227         }
 228 #endif
 229         str_set(stab_val(stab),buf);
 230         break;
 231     case '*':
 232         break;
 233     case '0':
 234         break;
 235     default:
 236         {
 237             struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
 238
 239             if (uf && uf->uf_val)
 240                 (*uf->uf_val)(uf->uf_index, stab_val(stab));
 241         }
 242         break;
 243     }
 244     return stab_val(stab);
 245 }
 246
 247 STRLEN
 248 stab_len(str)
 249 STR *str;
 250 {
 251     STAB *stab = str->str_u.str_stab;
 252     int paren;
 253     int i;
 254     char *s;
 255
 256     if (str->str_rare)
 257         return str_len(stab_val(stab));
 258
 259     switch (*stab->str_magic->str_ptr) {
 260     case '1': case '2': case '3': case '4':
 261     case '5': case '6': case '7': case '8': case '9': case '&':
 262         if (curspat) {
 263             paren = atoi(stab_name(stab));
 264           getparen:
 265             if (curspat->spat_regexp &&
 266               paren <= curspat->spat_regexp->nparens &&
 267               (s = curspat->spat_regexp->startp[paren]) ) {
 268                 i = curspat->spat_regexp->endp[paren] - s;
 269                 if (i >= 0)
 270                     return i;
 271                 else
 272                     return 0;
 273             }
 274             else
 275                 return 0;
 276         }
 277         break;
 278     case '+':
 279         if (curspat) {
 280             paren = curspat->spat_regexp->lastparen;
 281             goto getparen;
 282         }
 283         break;
 284     case '`':
 285         if (curspat) {
 286             if (curspat->spat_regexp &&
 287               (s = curspat->spat_regexp->subbeg) ) {
 288                 i = curspat->spat_regexp->startp[0] - s;
 289                 if (i >= 0)
 290                     return i;
 291                 else
 292                     return 0;
 293             }
 294             else
 295                 return 0;
 296         }
 297         break;
 298     case '\'':
 299         if (curspat) {
 300             if (curspat->spat_regexp &&
 301               (s = curspat->spat_regexp->endp[0]) ) {
 302                 return (STRLEN) (curspat->spat_regexp->subend - s);
 303             }
 304             else
 305                 return 0;
 306         }
 307         break;
 308     case ',':
 309         return (STRLEN)ofslen;
 310     case '\\':
 311         return (STRLEN)orslen;
 312     default:
 313         return str_len(stab_str(str));
 314     }
 315 }
 316
 317 stabset(mstr,str)
 318 register STR *mstr;
 319 STR *str;
 320 {
 321     STAB *stab;
 322     register char *s;
 323     int i;
 324
 325     switch (mstr->str_rare) {
 326     case 'E':
 327         setenv(mstr->str_ptr,str_get(str));
 328                                 /* And you'll never guess what the dog had */
 329                                 /*   in its mouth... */
 330 #ifdef TAINT
 331         if (strEQ(mstr->str_ptr,"PATH")) {
 332             char *strend = str->str_ptr + str->str_cur;
 333
 334             s = str->str_ptr;
 335             while (s < strend) {
 336                 s = cpytill(tokenbuf,s,strend,':',&i);
 337                 s++;
 338                 if (*tokenbuf != '/'
 339                   || (stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
 340                     str->str_tainted = 2;
 341             }
 342         }
 343 #endif
 344         break;
 345     case 'S':
 346         s = str_get(str);
 347         i = whichsig(mstr->str_ptr);    /* ...no, a brick */
 348         if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM")))
 349             warn("No such signal: SIG%s", mstr->str_ptr);
 350         if (strEQ(s,"IGNORE"))
 351 #ifndef lint
 352             (void)signal(i,SIG_IGN);
 353 #else
 354             ;
 355 #endif
 356         else if (strEQ(s,"DEFAULT") || !*s)
 357             (void)signal(i,SIG_DFL);
 358         else {
 359             (void)signal(i,sighandler);
 360             if (!index(s,'\'')) {
 361                 sprintf(tokenbuf, "main'%s",s);
 362                 str_set(str,tokenbuf);
 363             }
 364         }
 365         break;
 366 #ifdef SOME_DBM
 367     case 'D':
 368         stab = mstr->str_u.str_stab;
 369         hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
 370         break;
 371 #endif
 372     case 'L':
 373         {
 374             CMD *cmd;
 375
 376             stab = mstr->str_u.str_stab;
 377             i = str_true(str);
 378             str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
 379             cmd = str->str_magic->str_u.str_cmd;
 380             cmd->c_flags &= ~CF_OPTIMIZE;
 381             cmd->c_flags |= i? CFT_D1 : CFT_D0;
 382         }
 383         break;
 384     case '#':
 385         stab = mstr->str_u.str_stab;
 386         afill(stab_array(stab), (int)str_gnum(str) - arybase);
 387         break;
 388     case 'X':   /* merely a copy of a * string */
 389         break;
 390     case '*':
 391         s = str->str_pok ? str_get(str) : "";
 392         if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
 393             stab = mstr->str_u.str_stab;
 394             if (!*s) {
 395                 STBP *stbp;
 396
 397                 /*SUPPRESS 701*/
 398                 (void)savenostab(stab); /* schedule a free of this stab */
 399                 if (stab->str_len)
 400                     Safefree(stab->str_ptr);
 401                 Newz(601,stbp, 1, STBP);
 402                 stab->str_ptr = stbp;
 403                 stab->str_len = stab->str_cur = sizeof(STBP);
 404                 stab->str_pok = 1;
 405                 strcpy(stab_magic(stab),"StB");
 406                 stab_val(stab) = Str_new(70,0);
 407                 stab_line(stab) = curcmd->c_line;
 408                 stab_stash(stab) = curcmd->c_stash;
 409             }
 410             else {
 411                 stab = stabent(s,TRUE);
 412                 if (!stab_xarray(stab))
 413                     aadd(stab);
 414                 if (!stab_xhash(stab))
 415                     hadd(stab);
 416                 if (!stab_io(stab))
 417                     stab_io(stab) = stio_new();
 418             }
 419             str_sset(str, (STR*) stab);
 420         }
 421         break;
 422     case 's': {
 423             struct lstring *lstr = (struct lstring*)str;
 424             char *tmps;
 425
 426             mstr->str_rare = 0;
 427             str->str_magic = Nullstr;
 428             tmps = str_get(str);
 429             str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
 430               tmps,str->str_cur);
 431         }
 432         break;
 433
 434     case 'v':
 435         do_vecset(mstr,str);
 436         break;
 437
 438     case 0:
 439         /*SUPPRESS 560*/
 440         if (!(stab = mstr->str_u.str_stab))
 441             break;
 442         switch (*stab->str_magic->str_ptr) {
 443         case '\004':    /* ^D */
 444 #ifdef DEBUGGING
 445             debug = (int)(str_gnum(str)) | 32768;
 446             if (debug & 1024)
 447                 dump_all();
 448 #endif
 449             break;
 450         case '\006':    /* ^F */
 451             maxsysfd = (int)str_gnum(str);
 452             break;
 453         case '\t':      /* ^I */
 454             if (inplace)
 455                 Safefree(inplace);
 456             if (str->str_pok || str->str_nok)
 457                 inplace = savestr(str_get(str));
 458             else
 459                 inplace = Nullch;
 460             break;
 461         case '\020':    /* ^P */
 462             perldb = (int)str_gnum(str);
 463             break;
 464         case '\024':    /* ^T */
 465             basetime = (long)str_gnum(str);
 466             break;
 467         case '\027':    /* ^W */
 468             dowarn = (bool)str_gnum(str);
 469             break;
 470         case '.':
 471             if (localizing)
 472                 savesptr((STR**)&last_in_stab);
 473             break;
 474         case '^':
 475             Safefree(stab_io(curoutstab)->top_name);
 476             stab_io(curoutstab)->top_name = s = savestr(str_get(str));
 477             stab_io(curoutstab)->top_stab = stabent(s,TRUE);
 478             break;
 479         case '~':
 480             Safefree(stab_io(curoutstab)->fmt_name);
 481             stab_io(curoutstab)->fmt_name = s = savestr(str_get(str));
 482             stab_io(curoutstab)->fmt_stab = stabent(s,TRUE);
 483             break;
 484         case '=':
 485             stab_io(curoutstab)->page_len = (long)str_gnum(str);
 486             break;
 487         case '-':
 488             stab_io(curoutstab)->lines_left = (long)str_gnum(str);
 489             if (stab_io(curoutstab)->lines_left < 0L)
 490                 stab_io(curoutstab)->lines_left = 0L;
 491             break;
 492         case '%':
 493             stab_io(curoutstab)->page = (long)str_gnum(str);
 494             break;
 495         case '|':
 496             if (!stab_io(curoutstab))
 497                 stab_io(curoutstab) = stio_new();
 498             stab_io(curoutstab)->flags &= ~IOF_FLUSH;
 499             if (str_gnum(str) != 0.0) {
 500                 stab_io(curoutstab)->flags |= IOF_FLUSH;
 501             }
 502             break;
 503         case '*':
 504             i = (int)str_gnum(str);
 505             multiline = (i != 0);
 506             break;
 507         case '/':
 508             if (str->str_pok) {
 509                 rs = str_get(str);
 510                 rslen = str->str_cur;
 511                 if (!rslen) {
 512                     rs = "\n\n";
 513                     rslen = 2;
 514                 }
 515                 rschar = rs[rslen - 1];
 516             }
 517             else {
 518                 rschar = 0777;  /* fake a non-existent char */
 519                 rslen = 1;
 520             }
 521             break;
 522         case '\\':
 523             if (ors)
 524                 Safefree(ors);
 525             ors = savestr(str_get(str));
 526             orslen = str->str_cur;
 527             break;
 528         case ',':
 529             if (ofs)
 530                 Safefree(ofs);
 531             ofs = savestr(str_get(str));
 532             ofslen = str->str_cur;
 533             break;
 534         case '#':
 535             if (ofmt)
 536                 Safefree(ofmt);
 537             ofmt = savestr(str_get(str));
 538             break;
 539         case '[':
 540             arybase = (int)str_gnum(str);
 541             break;
 542         case '?':
 543             statusvalue = U_S(str_gnum(str));
 544             break;
 545         case '!':
 546             errno = (int)str_gnum(str);         /* will anyone ever use this? */
 547             break;
 548         case '<':
 549             uid = (int)str_gnum(str);
 550 #if defined(HAS_SETREUID) || !defined(HAS_SETRUID)
 551             if (delaymagic) {
 552                 delaymagic |= DM_REUID;
 553                 break;                          /* don't do magic till later */
 554             }
 555 #endif /* HAS_SETREUID or not HASSETRUID */
 556 #ifdef HAS_SETRUID
 557             if (setruid((UIDTYPE)uid) < 0)
 558                 uid = (int)getuid();
 559 #else
 560 #ifdef HAS_SETREUID
 561             if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
 562                 uid = (int)getuid();
 563 #else
 564             if (uid == euid)            /* special case $< = $> */
 565                 setuid(uid);
 566             else
 567                 fatal("setruid() not implemented");
 568 #endif
 569 #endif
 570             break;
 571         case '>':
 572             euid = (int)str_gnum(str);
 573 #if defined(HAS_SETREUID) || !defined(HAS_SETEUID)
 574             if (delaymagic) {
 575                 delaymagic |= DM_REUID;
 576                 break;                          /* don't do magic till later */
 577             }
 578 #endif /* HAS_SETREUID or not HAS_SETEUID */
 579 #ifdef HAS_SETEUID
 580             if (seteuid((UIDTYPE)euid) < 0)
 581                 euid = (int)geteuid();
 582 #else
 583 #ifdef HAS_SETREUID
 584             if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
 585                 euid = (int)geteuid();
 586 #else
 587             if (euid == uid)            /* special case $> = $< */
 588                 setuid(euid);
 589             else
 590                 fatal("seteuid() not implemented");
 591 #endif
 592 #endif
 593             break;
 594         case '(':
 595             gid = (int)str_gnum(str);
 596 #if defined(HAS_SETREGID) || !defined(HAS_SETRGID)
 597             if (delaymagic) {
 598                 delaymagic |= DM_REGID;
 599                 break;                          /* don't do magic till later */
 600             }
 601 #endif /* HAS_SETREGID or not HAS_SETRGID */
 602 #ifdef HAS_SETRGID
 603             (void)setrgid((GIDTYPE)gid);
 604 #else
 605 #ifdef HAS_SETREGID
 606             (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
 607 #else
 608             fatal("setrgid() not implemented");
 609 #endif
 610 #endif
 611             break;
 612         case ')':
 613             egid = (int)str_gnum(str);
 614 #if defined(HAS_SETREGID) || !defined(HAS_SETEGID)
 615             if (delaymagic) {
 616                 delaymagic |= DM_REGID;
 617                 break;                          /* don't do magic till later */
 618             }
 619 #endif /* HAS_SETREGID or not HAS_SETEGID */
 620 #ifdef HAS_SETEGID
 621             (void)setegid((GIDTYPE)egid);
 622 #else
 623 #ifdef HAS_SETREGID
 624             (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
 625 #else
 626             fatal("setegid() not implemented");
 627 #endif
 628 #endif
 629             break;
 630         case ':':
 631             chopset = str_get(str);
 632             break;
 633         case '0':
 634             if (!origalen) {
 635                 s = origargv[0];
 636                 s += strlen(s);
 637                 /* See if all the arguments are contiguous in memory */
 638                 for (i = 1; i < origargc; i++) {
 639                     if (origargv[i] == s + 1)
 640                         s += strlen(++s);       /* this one is ok too */
 641                 }
 642                 if (origenviron[0] == s + 1) {  /* can grab env area too? */
 643                     setenv("NoNeSuCh", Nullch); /* force copy of environment */
 644                     for (i = 0; origenviron[i]; i++)
 645                         if (origenviron[i] == s + 1)
 646                             s += strlen(++s);
 647                 }
 648                 origalen = s - origargv[0];
 649             }
 650             s = str_get(str);
 651             i = str->str_cur;
 652             if (i >= origalen) {
 653                 i = origalen;
 654                 str->str_cur = i;
 655                 str->str_ptr[i] = '\0';
 656                 bcopy(s, origargv[0], i);
 657             }
 658             else {
 659                 bcopy(s, origargv[0], i);
 660                 s = origargv[0]+i;
 661                 *s++ = '\0';
 662                 while (++i < origalen)
 663                     *s++ = ' ';
 664             }
 665             break;
 666         default:
 667             {
 668                 struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
 669
 670                 if (uf && uf->uf_set)
 671                     (*uf->uf_set)(uf->uf_index, str);
 672             }
 673             break;
 674         }
 675         break;
 676     }
 677 }
 678
 679 whichsig(sig)
 680 char *sig;
 681 {
 682     register char **sigv;
 683
 684     for (sigv = sig_name+1; *sigv; sigv++)
 685         if (strEQ(sig,*sigv))
 686             return sigv - sig_name;
 687 #ifdef SIGCLD
 688     if (strEQ(sig,"CHLD"))
 689         return SIGCLD;
 690 #endif
 691 #ifdef SIGCHLD
 692     if (strEQ(sig,"CLD"))
 693         return SIGCHLD;
 694 #endif
 695     return 0;
 696 }
 697
 698 static handlertype
 699 sighandler(sig)
 700 int sig;
 701 {
 702     STAB *stab;
 703     STR *str;
 704     int oldsave = savestack->ary_fill;
 705     int oldtmps_base = tmps_base;
 706     register CSV *csv;
 707     SUBR *sub;
 708
 709 #ifdef OS2              /* or anybody else who requires SIG_ACK */
 710     signal(sig, SIG_ACK);
 711 #endif
 712     stab = stabent(
 713         str_get(hfetch(stab_hash(sigstab),sig_name[sig],strlen(sig_name[sig]),
 714           TRUE)), TRUE);
 715     sub = stab_sub(stab);
 716     if (!sub && *sig_name[sig] == 'C' && instr(sig_name[sig],"LD")) {
 717         if (sig_name[sig][1] == 'H')
 718             stab = stabent(str_get(hfetch(stab_hash(sigstab),"CLD",3,TRUE)),
 719               TRUE);
 720         else
 721             stab = stabent(str_get(hfetch(stab_hash(sigstab),"CHLD",4,TRUE)),
 722               TRUE);
 723         sub = stab_sub(stab);   /* gag */
 724     }
 725     if (!sub) {
 726         if (dowarn)
 727             warn("SIG%s handler \"%s\" not defined.\n",
 728                 sig_name[sig], stab_name(stab) );
 729         return;
 730     }
 731     /*SUPPRESS 701*/
 732     saveaptr(&stack);
 733     str = Str_new(15, sizeof(CSV));
 734     str->str_state = SS_SCSV;
 735     (void)apush(savestack,str);
 736     csv = (CSV*)str->str_ptr;
 737     csv->sub = sub;
 738     csv->stab = stab;
 739     csv->curcsv = curcsv;
 740     csv->curcmd = curcmd;
 741     csv->depth = sub->depth;
 742     csv->wantarray = G_SCALAR;
 743     csv->hasargs = TRUE;
 744     csv->savearray = stab_xarray(defstab);
 745     csv->argarray = stab_xarray(defstab) = stack = anew(defstab);
 746     stack->ary_flags = 0;
 747     curcsv = csv;
 748     str = str_mortal(&str_undef);
 749     str_set(str,sig_name[sig]);
 750     (void)apush(stab_xarray(defstab),str);
 751     sub->depth++;
 752     if (sub->depth >= 2) {      /* save temporaries on recursion? */
 753         if (sub->depth == 100 && dowarn)
 754             warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
 755         savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
 756     }
 757
 758     tmps_base = tmps_max;               /* protect our mortal string */
 759     (void)cmd_exec(sub->cmd,G_SCALAR,0);                /* so do it already */
 760     tmps_base = oldtmps_base;
 761
 762     restorelist(oldsave);               /* put everything back */
 763 }
 764
 765 STAB *
 766 aadd(stab)
 767 register STAB *stab;
 768 {
 769     if (!stab_xarray(stab))
 770         stab_xarray(stab) = anew(stab);
 771     return stab;
 772 }
 773
 774 STAB *
 775 hadd(stab)
 776 register STAB *stab;
 777 {
 778     if (!stab_xhash(stab))
 779         stab_xhash(stab) = hnew(COEFFSIZE);
 780     return stab;
 781 }
 782
 783 STAB *
 784 fstab(name)
 785 char *name;
 786 {
 787     char tmpbuf[1200];
 788     STAB *stab;
 789
 790     sprintf(tmpbuf,"'_<%s", name);
 791     stab = stabent(tmpbuf, TRUE);
 792     str_set(stab_val(stab), name);
 793     if (perldb)
 794         (void)hadd(aadd(stab));
 795     return stab;
 796 }
 797
 798 STAB *
 799 stabent(name,add)
 800 register char *name;
 801 int add;
 802 {
 803     register STAB *stab;
 804     register STBP *stbp;
 805     int len;
 806     register char *namend;
 807     HASH *stash;
 808     char *sawquote = Nullch;
 809     char *prevquote = Nullch;
 810     bool global = FALSE;
 811
 812     if (isUPPER(*name)) {
 813         if (*name > 'I') {
 814             if (*name == 'S' && (
 815               strEQ(name, "SIG") ||
 816               strEQ(name, "STDIN") ||
 817               strEQ(name, "STDOUT") ||
 818               strEQ(name, "STDERR") ))
 819                 global = TRUE;
 820         }
 821         else if (*name > 'E') {
 822             if (*name == 'I' && strEQ(name, "INC"))
 823                 global = TRUE;
 824         }
 825         else if (*name > 'A') {
 826             if (*name == 'E' && strEQ(name, "ENV"))
 827                 global = TRUE;
 828         }
 829         else if (*name == 'A' && (
 830           strEQ(name, "ARGV") ||
 831           strEQ(name, "ARGVOUT") ))
 832             global = TRUE;
 833     }
 834     for (namend = name; *namend; namend++) {
 835         if (*namend == '\'' && namend[1])
 836             prevquote = sawquote, sawquote = namend;
 837     }
 838     if (sawquote == name && name[1]) {
 839         stash = defstash;
 840         sawquote = Nullch;
 841         name++;
 842     }
 843     else if (!isALPHA(*name) || global)
 844         stash = defstash;
 845     else if ((CMD*)curcmd == &compiling)
 846         stash = curstash;
 847     else
 848         stash = curcmd->c_stash;
 849     if (sawquote) {
 850         char tmpbuf[256];
 851         char *s, *d;
 852
 853         *sawquote = '\0';
 854         /*SUPPRESS 560*/
 855         if (s = prevquote) {
 856             strncpy(tmpbuf,name,s-name+1);
 857             d = tmpbuf+(s-name+1);
 858             *d++ = '_';
 859             strcpy(d,s+1);
 860         }
 861         else {
 862             *tmpbuf = '_';
 863             strcpy(tmpbuf+1,name);
 864         }
 865         stab = stabent(tmpbuf,TRUE);
 866         if (!(stash = stab_xhash(stab)))
 867             stash = stab_xhash(stab) = hnew(0);
 868         if (!stash->tbl_name)
 869             stash->tbl_name = savestr(name);
 870         name = sawquote+1;
 871         *sawquote = '\'';
 872     }
 873     len = namend - name;
 874     stab = (STAB*)hfetch(stash,name,len,add);
 875     if (stab == (STAB*)&str_undef)
 876         return Nullstab;
 877     if (stab->str_pok) {
 878         stab->str_pok |= SP_MULTI;
 879         return stab;
 880     }
 881     else {
 882         if (stab->str_len)
 883             Safefree(stab->str_ptr);
 884         Newz(602,stbp, 1, STBP);
 885         stab->str_ptr = stbp;
 886         stab->str_len = stab->str_cur = sizeof(STBP);
 887         stab->str_pok = 1;
 888         strcpy(stab_magic(stab),"StB");
 889         stab_val(stab) = Str_new(72,0);
 890         stab_line(stab) = curcmd->c_line;
 891         str_magic((STR*)stab, stab, '*', name, len);
 892         stab_stash(stab) = stash;
 893         if (isDIGIT(*name) && *name != '0') {
 894             stab_flags(stab) = SF_VMAGIC;
 895             str_magic(stab_val(stab), stab, 0, Nullch, 0);
 896         }
 897         if (add & 2)
 898             stab->str_pok |= SP_MULTI;
 899         return stab;
 900     }
 901 }
 902
 903 stab_fullname(str,stab)
 904 STR *str;
 905 STAB *stab;
 906 {
 907     HASH *tb = stab_stash(stab);
 908
 909     if (!tb)
 910         return;
 911     str_set(str,tb->tbl_name);
 912     str_ncat(str,"'", 1);
 913     str_scat(str,stab->str_magic);
 914 }
 915
 916 STIO *
 917 stio_new()
 918 {
 919     STIO *stio;
 920
 921     Newz(603,stio,1,STIO);
 922     stio->page_len = 60;
 923     return stio;
 924 }
 925
 926 stab_check(min,max)
 927 int min;
 928 register int max;
 929 {
 930     register HENT *entry;
 931     register int i;
 932     register STAB *stab;
 933
 934     for (i = min; i <= max; i++) {
 935         for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
 936             stab = (STAB*)entry->hent_val;
 937             if (stab->str_pok & SP_MULTI)
 938                 continue;
 939             curcmd->c_line = stab_line(stab);
 940             warn("Possible typo: \"%s\"", stab_name(stab));
 941         }
 942     }
 943 }
 944
 945 static int gensym = 0;
 946
 947 STAB *
 948 genstab()
 949 {
 950     (void)sprintf(tokenbuf,"_GEN_%d",gensym++);
 951     return stabent(tokenbuf,TRUE);
 952 }
 953
 954 /* hopefully this is only called on local symbol table entries */
 955
 956 void
 957 stab_clear(stab)
 958 register STAB *stab;
 959 {
 960     STIO *stio;
 961     SUBR *sub;
 962
 963     afree(stab_xarray(stab));
 964     stab_xarray(stab) = Null(ARRAY*);
 965     (void)hfree(stab_xhash(stab), FALSE);
 966     stab_xhash(stab) = Null(HASH*);
 967     str_free(stab_val(stab));
 968     stab_val(stab) = Nullstr;
 969     /*SUPPRESS 560*/
 970     if (stio = stab_io(stab)) {
 971         do_close(stab,FALSE);
 972         Safefree(stio->top_name);
 973         Safefree(stio->fmt_name);
 974         Safefree(stio);
 975     }
 976     /*SUPPRESS 560*/
 977     if (sub = stab_sub(stab)) {
 978         afree(sub->tosave);
 979         cmd_free(sub->cmd);
 980     }
 981     Safefree(stab->str_ptr);
 982     stab->str_ptr = Null(STBP*);
 983     stab->str_len = 0;
 984     stab->str_cur = 0;
 985 }
 986
 987 #if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
 988 #define MICROPORT
 989 #endif
 990
 991 #ifdef  MICROPORT       /* Microport 2.4 hack */
 992 ARRAY *stab_array(stab)
 993 register STAB *stab;
 994 {
 995     if (((STBP*)(stab->str_ptr))->stbp_array)
 996         return ((STBP*)(stab->str_ptr))->stbp_array;
 997     else
 998         return ((STBP*)(aadd(stab)->str_ptr))->stbp_array;
 999 }
1000
1001 HASH *stab_hash(stab)
1002 register STAB *stab;
1003 {
1004     if (((STBP*)(stab->str_ptr))->stbp_hash)
1005         return ((STBP*)(stab->str_ptr))->stbp_hash;
1006     else
1007         return ((STBP*)(hadd(stab)->str_ptr))->stbp_hash;
1008 }
1009 #endif                  /* Microport 2.4 hack */