stab.c

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