stab.c

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