This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 4.0 patch 16: patch #11, continued
[perl5.git] / stab.c
CommitLineData
f0fcb552 1/* $RCSfile: stab.c,v $$Revision: 4.0.1.3 $$Date: 91/11/05 18:35:33 $
a687059c 2 *
9ef589d8 3 * Copyright (c) 1991, Larry Wall
a687059c 4 *
9ef589d8
LW
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.
8d063cd8
LW
7 *
8 * $Log: stab.c,v $
f0fcb552
LW
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 *
9ef589d8
LW
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 *
35c8bce7
LW
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 *
fe14fcc3
LW
29 * Revision 4.0 91/03/20 01:39:41 lwall
30 * 4.0 baseline.
8d063cd8
LW
31 *
32 */
33
8d063cd8 34#include "EXTERN.h"
8d063cd8
LW
35#include "perl.h"
36
6eb13c3b 37#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
378cc40b 38#include <signal.h>
00bf170e 39#endif
378cc40b 40
8d063cd8 41static char *sig_name[] = {
a687059c
LW
42 SIG_NAME,0
43};
8d063cd8 44
663a0e37
LW
45#ifdef VOIDSIG
46#define handlertype void
47#else
48#define handlertype int
49#endif
2e1b3b7e 50
34de22dd
LW
51static handlertype sighandler();
52
fe14fcc3
LW
53static int origalen = 0;
54
8d063cd8 55STR *
a687059c
LW
56stab_str(str)
57STR *str;
8d063cd8 58{
a687059c 59 STAB *stab = str->str_u.str_stab;
8d063cd8
LW
60 register int paren;
61 register char *s;
378cc40b 62 register int i;
8d063cd8 63
a687059c
LW
64 if (str->str_rare)
65 return stab_val(stab);
66
67 switch (*stab->str_magic->str_ptr) {
fe14fcc3
LW
68 case '\004': /* ^D */
69#ifdef DEBUGGING
70 str_numset(stab_val(stab),(double)(debug & 32767));
71#endif
72 break;
9ef589d8
LW
73 case '\006': /* ^F */
74 str_numset(stab_val(stab),(double)maxsysfd);
75 break;
fe14fcc3
LW
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;
9ef589d8
LW
82 case '\020': /* ^P */
83 str_numset(stab_val(stab),(double)perldb);
84 break;
0a12ae7d
LW
85 case '\024': /* ^T */
86 str_numset(stab_val(stab),(double)basetime);
87 break;
fe14fcc3
LW
88 case '\027': /* ^W */
89 str_numset(stab_val(stab),(double)dowarn);
90 break;
9f68db38 91 case '1': case '2': case '3': case '4':
8d063cd8
LW
92 case '5': case '6': case '7': case '8': case '9': case '&':
93 if (curspat) {
a687059c 94 paren = atoi(stab_name(stab));
378cc40b
LW
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)
a687059c 101 str_nset(stab_val(stab),s,i);
378cc40b 102 else
a687059c 103 str_sset(stab_val(stab),&str_undef);
8d063cd8 104 }
378cc40b 105 else
a687059c 106 str_sset(stab_val(stab),&str_undef);
8d063cd8
LW
107 }
108 break;
109 case '+':
110 if (curspat) {
378cc40b
LW
111 paren = curspat->spat_regexp->lastparen;
112 goto getparen;
8d063cd8
LW
113 }
114 break;
a687059c
LW
115 case '`':
116 if (curspat) {
117 if (curspat->spat_regexp &&
9ef589d8 118 (s = curspat->spat_regexp->subbeg) ) {
a687059c
LW
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]) ) {
00bf170e 133 str_nset(stab_val(stab),s, curspat->spat_regexp->subend - s);
a687059c
LW
134 }
135 else
136 str_nset(stab_val(stab),"",0);
137 }
138 break;
8d063cd8 139 case '.':
a687059c 140#ifndef lint
8d063cd8 141 if (last_in_stab) {
a687059c 142 str_numset(stab_val(stab),(double)stab_io(last_in_stab)->lines);
8d063cd8 143 }
a687059c 144#endif
8d063cd8
LW
145 break;
146 case '?':
a687059c 147 str_numset(stab_val(stab),(double)statusvalue);
8d063cd8
LW
148 break;
149 case '^':
a687059c 150 s = stab_io(curoutstab)->top_name;
9ef589d8
LW
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 }
8d063cd8
LW
157 break;
158 case '~':
a687059c 159 s = stab_io(curoutstab)->fmt_name;
9ef589d8
LW
160 if (!s)
161 s = stab_name(curoutstab);
a687059c 162 str_set(stab_val(stab),s);
8d063cd8 163 break;
a687059c 164#ifndef lint
8d063cd8 165 case '=':
a687059c 166 str_numset(stab_val(stab),(double)stab_io(curoutstab)->page_len);
8d063cd8
LW
167 break;
168 case '-':
a687059c 169 str_numset(stab_val(stab),(double)stab_io(curoutstab)->lines_left);
8d063cd8
LW
170 break;
171 case '%':
a687059c 172 str_numset(stab_val(stab),(double)stab_io(curoutstab)->page);
8d063cd8 173 break;
a687059c 174#endif
8d063cd8 175 case '/':
8d063cd8
LW
176 break;
177 case '[':
a687059c 178 str_numset(stab_val(stab),(double)arybase);
8d063cd8
LW
179 break;
180 case '|':
00bf170e
LW
181 if (!stab_io(curoutstab))
182 stab_io(curoutstab) = stio_new();
a687059c
LW
183 str_numset(stab_val(stab),
184 (double)((stab_io(curoutstab)->flags & IOF_FLUSH) != 0) );
8d063cd8
LW
185 break;
186 case ',':
a687059c 187 str_nset(stab_val(stab),ofs,ofslen);
8d063cd8
LW
188 break;
189 case '\\':
a687059c 190 str_nset(stab_val(stab),ors,orslen);
8d063cd8
LW
191 break;
192 case '#':
a687059c 193 str_set(stab_val(stab),ofmt);
8d063cd8
LW
194 break;
195 case '!':
a687059c 196 str_numset(stab_val(stab), (double)errno);
00bf170e 197 str_set(stab_val(stab), errno ? strerror(errno) : "");
a687059c 198 stab_val(stab)->str_nok = 1; /* what a wonderful hack! */
378cc40b
LW
199 break;
200 case '<':
a687059c 201 str_numset(stab_val(stab),(double)uid);
378cc40b
LW
202 break;
203 case '>':
a687059c 204 str_numset(stab_val(stab),(double)euid);
378cc40b
LW
205 break;
206 case '(':
a687059c
LW
207 s = buf;
208 (void)sprintf(s,"%d",(int)gid);
378cc40b
LW
209 goto add_groups;
210 case ')':
a687059c
LW
211 s = buf;
212 (void)sprintf(s,"%d",(int)egid);
378cc40b
LW
213 add_groups:
214 while (*s) s++;
fe14fcc3 215#ifdef HAS_GETGROUPS
378cc40b
LW
216#ifndef NGROUPS
217#define NGROUPS 32
218#endif
219 {
35c8bce7 220 GROUPSTYPE gary[NGROUPS];
378cc40b
LW
221
222 i = getgroups(NGROUPS,gary);
223 while (--i >= 0) {
a687059c 224 (void)sprintf(s," %ld", (long)gary[i]);
378cc40b
LW
225 while (*s) s++;
226 }
227 }
228#endif
a687059c 229 str_set(stab_val(stab),buf);
8d063cd8 230 break;
fe14fcc3
LW
231 case '*':
232 break;
233 case '0':
234 break;
00bf170e
LW
235 default:
236 {
237 struct ufuncs *uf = (struct ufuncs *)str->str_ptr;
238
239 if (uf && uf->uf_val)
0a12ae7d 240 (*uf->uf_val)(uf->uf_index, stab_val(stab));
00bf170e
LW
241 }
242 break;
8d063cd8 243 }
a687059c 244 return stab_val(stab);
8d063cd8
LW
245}
246
9ef589d8
LW
247STRLEN
248stab_len(str)
249STR *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)
f0fcb552 257 return str_len(stab_val(stab));
9ef589d8
LW
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:
f0fcb552 313 return str_len(stab_str(str));
9ef589d8
LW
314 }
315}
316
a687059c
LW
317stabset(mstr,str)
318register STR *mstr;
8d063cd8
LW
319STR *str;
320{
f0fcb552 321 STAB *stab;
fe14fcc3 322 register char *s;
8d063cd8 323 int i;
8d063cd8 324
a687059c
LW
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 */
0a12ae7d
LW
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;
a687059c
LW
345 case 'S':
346 s = str_get(str);
347 i = whichsig(mstr->str_ptr); /* ...no, a brick */
f0fcb552
LW
348 if (!i && (dowarn || strEQ(mstr->str_ptr,"ALARM")))
349 warn("No such signal: SIG%s", mstr->str_ptr);
a687059c
LW
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);
0a12ae7d 358 else {
a687059c 359 (void)signal(i,sighandler);
0a12ae7d
LW
360 if (!index(s,'\'')) {
361 sprintf(tokenbuf, "main'%s",s);
362 str_set(str,tokenbuf);
363 }
364 }
a687059c
LW
365 break;
366#ifdef SOME_DBM
367 case 'D':
f0fcb552 368 stab = mstr->str_u.str_stab;
a687059c
LW
369 hdbmstore(stab_hash(stab),mstr->str_ptr,mstr->str_cur,str);
370 break;
371#endif
0a12ae7d
LW
372 case 'L':
373 {
374 CMD *cmd;
375
f0fcb552 376 stab = mstr->str_u.str_stab;
0a12ae7d 377 i = str_true(str);
34de22dd 378 str = afetch(stab_xarray(stab),atoi(mstr->str_ptr), FALSE);
0a12ae7d
LW
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;
a687059c 384 case '#':
f0fcb552 385 stab = mstr->str_u.str_stab;
a687059c
LW
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 '*':
f0fcb552 391 s = str->str_pok ? str_get(str) : "";
9f68db38 392 if (strNE(s,"StB") || str->str_cur != sizeof(STBP)) {
f0fcb552 393 stab = mstr->str_u.str_stab;
a687059c
LW
394 if (!*s) {
395 STBP *stbp;
396
f0fcb552 397 /*SUPPRESS 701*/
a687059c
LW
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;
9f68db38 405 strcpy(stab_magic(stab),"StB");
a687059c 406 stab_val(stab) = Str_new(70,0);
00bf170e 407 stab_line(stab) = curcmd->c_line;
fe14fcc3 408 stab_stash(stab) = curcmd->c_stash;
a687059c 409 }
00bf170e 410 else {
a687059c 411 stab = stabent(s,TRUE);
00bf170e
LW
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 }
f0fcb552 419 str_sset(str, (STR*) stab);
a687059c
LW
420 }
421 break;
422 case 's': {
423 struct lstring *lstr = (struct lstring*)str;
fe14fcc3 424 char *tmps;
a687059c
LW
425
426 mstr->str_rare = 0;
427 str->str_magic = Nullstr;
fe14fcc3 428 tmps = str_get(str);
a687059c 429 str_insert(mstr,lstr->lstr_offset,lstr->lstr_len,
fe14fcc3 430 tmps,str->str_cur);
a687059c
LW
431 }
432 break;
433
434 case 'v':
435 do_vecset(mstr,str);
436 break;
437
438 case 0:
f0fcb552
LW
439 /*SUPPRESS 560*/
440 if (!(stab = mstr->str_u.str_stab))
441 break;
a687059c 442 switch (*stab->str_magic->str_ptr) {
fe14fcc3
LW
443 case '\004': /* ^D */
444#ifdef DEBUGGING
445 debug = (int)(str_gnum(str)) | 32768;
9ef589d8
LW
446 if (debug & 1024)
447 dump_all();
fe14fcc3
LW
448#endif
449 break;
9ef589d8
LW
450 case '\006': /* ^F */
451 maxsysfd = (int)str_gnum(str);
452 break;
fe14fcc3
LW
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;
9ef589d8
LW
461 case '\020': /* ^P */
462 perldb = (int)str_gnum(str);
463 break;
0a12ae7d
LW
464 case '\024': /* ^T */
465 basetime = (long)str_gnum(str);
466 break;
fe14fcc3
LW
467 case '\027': /* ^W */
468 dowarn = (bool)str_gnum(str);
469 break;
9f68db38
LW
470 case '.':
471 if (localizing)
472 savesptr((STR**)&last_in_stab);
473 break;
8d063cd8 474 case '^':
a687059c
LW
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);
8d063cd8
LW
478 break;
479 case '~':
a687059c
LW
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);
8d063cd8
LW
483 break;
484 case '=':
a687059c 485 stab_io(curoutstab)->page_len = (long)str_gnum(str);
8d063cd8
LW
486 break;
487 case '-':
a687059c
LW
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;
8d063cd8
LW
491 break;
492 case '%':
a687059c 493 stab_io(curoutstab)->page = (long)str_gnum(str);
8d063cd8
LW
494 break;
495 case '|':
00bf170e
LW
496 if (!stab_io(curoutstab))
497 stab_io(curoutstab) = stio_new();
a687059c 498 stab_io(curoutstab)->flags &= ~IOF_FLUSH;
8d063cd8 499 if (str_gnum(str) != 0.0) {
a687059c 500 stab_io(curoutstab)->flags |= IOF_FLUSH;
8d063cd8
LW
501 }
502 break;
503 case '*':
a687059c
LW
504 i = (int)str_gnum(str);
505 multiline = (i != 0);
8d063cd8
LW
506 break;
507 case '/':
79a0689e 508 if (str->str_pok) {
fe14fcc3 509 rs = str_get(str);
9f68db38 510 rslen = str->str_cur;
fe14fcc3
LW
511 if (!rslen) {
512 rs = "\n\n";
513 rslen = 2;
514 }
515 rschar = rs[rslen - 1];
9f68db38
LW
516 }
517 else {
fe14fcc3 518 rschar = 0777; /* fake a non-existent char */
9f68db38
LW
519 rslen = 1;
520 }
8d063cd8
LW
521 break;
522 case '\\':
523 if (ors)
a687059c 524 Safefree(ors);
8d063cd8 525 ors = savestr(str_get(str));
a687059c 526 orslen = str->str_cur;
8d063cd8
LW
527 break;
528 case ',':
529 if (ofs)
a687059c 530 Safefree(ofs);
8d063cd8 531 ofs = savestr(str_get(str));
a687059c 532 ofslen = str->str_cur;
8d063cd8
LW
533 break;
534 case '#':
535 if (ofmt)
a687059c 536 Safefree(ofmt);
8d063cd8
LW
537 ofmt = savestr(str_get(str));
538 break;
539 case '[':
540 arybase = (int)str_gnum(str);
541 break;
378cc40b 542 case '?':
0f85fab0 543 statusvalue = U_S(str_gnum(str));
378cc40b 544 break;
8d063cd8
LW
545 case '!':
546 errno = (int)str_gnum(str); /* will anyone ever use this? */
547 break;
378cc40b 548 case '<':
378cc40b 549 uid = (int)str_gnum(str);
9ef589d8 550#if defined(HAS_SETREUID) || !defined(HAS_SETRUID)
a687059c
LW
551 if (delaymagic) {
552 delaymagic |= DM_REUID;
553 break; /* don't do magic till later */
554 }
9ef589d8 555#endif /* HAS_SETREUID or not HASSETRUID */
fe14fcc3 556#ifdef HAS_SETRUID
a687059c
LW
557 if (setruid((UIDTYPE)uid) < 0)
558 uid = (int)getuid();
559#else
fe14fcc3 560#ifdef HAS_SETREUID
a687059c 561 if (setreuid((UIDTYPE)uid, (UIDTYPE)-1) < 0)
378cc40b
LW
562 uid = (int)getuid();
563#else
00bf170e
LW
564 if (uid == euid) /* special case $< = $> */
565 setuid(uid);
566 else
567 fatal("setruid() not implemented");
378cc40b 568#endif
a687059c 569#endif
378cc40b
LW
570 break;
571 case '>':
378cc40b 572 euid = (int)str_gnum(str);
9ef589d8 573#if defined(HAS_SETREUID) || !defined(HAS_SETEUID)
a687059c
LW
574 if (delaymagic) {
575 delaymagic |= DM_REUID;
576 break; /* don't do magic till later */
577 }
9ef589d8 578#endif /* HAS_SETREUID or not HAS_SETEUID */
fe14fcc3 579#ifdef HAS_SETEUID
a687059c
LW
580 if (seteuid((UIDTYPE)euid) < 0)
581 euid = (int)geteuid();
582#else
fe14fcc3 583#ifdef HAS_SETREUID
a687059c 584 if (setreuid((UIDTYPE)-1, (UIDTYPE)euid) < 0)
378cc40b
LW
585 euid = (int)geteuid();
586#else
00bf170e
LW
587 if (euid == uid) /* special case $> = $< */
588 setuid(euid);
589 else
590 fatal("seteuid() not implemented");
378cc40b 591#endif
a687059c 592#endif
378cc40b
LW
593 break;
594 case '(':
a687059c 595 gid = (int)str_gnum(str);
9ef589d8 596#if defined(HAS_SETREGID) || !defined(HAS_SETRGID)
a687059c
LW
597 if (delaymagic) {
598 delaymagic |= DM_REGID;
599 break; /* don't do magic till later */
600 }
9ef589d8 601#endif /* HAS_SETREGID or not HAS_SETRGID */
fe14fcc3 602#ifdef HAS_SETRGID
a687059c
LW
603 (void)setrgid((GIDTYPE)gid);
604#else
fe14fcc3 605#ifdef HAS_SETREGID
a687059c 606 (void)setregid((GIDTYPE)gid, (GIDTYPE)-1);
378cc40b
LW
607#else
608 fatal("setrgid() not implemented");
609#endif
a687059c 610#endif
378cc40b
LW
611 break;
612 case ')':
a687059c 613 egid = (int)str_gnum(str);
9ef589d8 614#if defined(HAS_SETREGID) || !defined(HAS_SETEGID)
a687059c
LW
615 if (delaymagic) {
616 delaymagic |= DM_REGID;
617 break; /* don't do magic till later */
618 }
9ef589d8 619#endif /* HAS_SETREGID or not HAS_SETEGID */
fe14fcc3 620#ifdef HAS_SETEGID
a687059c
LW
621 (void)setegid((GIDTYPE)egid);
622#else
fe14fcc3 623#ifdef HAS_SETREGID
a687059c 624 (void)setregid((GIDTYPE)-1, (GIDTYPE)egid);
378cc40b
LW
625#else
626 fatal("setegid() not implemented");
627#endif
a687059c
LW
628#endif
629 break;
630 case ':':
631 chopset = str_get(str);
378cc40b 632 break;
fe14fcc3
LW
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;
00bf170e
LW
666 default:
667 {
668 struct ufuncs *uf = (struct ufuncs *)str->str_magic->str_ptr;
669
670 if (uf && uf->uf_set)
0a12ae7d 671 (*uf->uf_set)(uf->uf_index, str);
00bf170e
LW
672 }
673 break;
8d063cd8 674 }
a687059c 675 break;
378cc40b 676 }
8d063cd8
LW
677}
678
378cc40b
LW
679whichsig(sig)
680char *sig;
8d063cd8
LW
681{
682 register char **sigv;
683
684 for (sigv = sig_name+1; *sigv; sigv++)
378cc40b 685 if (strEQ(sig,*sigv))
8d063cd8 686 return sigv - sig_name;
a687059c
LW
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
8d063cd8
LW
695 return 0;
696}
697
663a0e37 698static handlertype
8d063cd8
LW
699sighandler(sig)
700int sig;
701{
702 STAB *stab;
8d063cd8 703 STR *str;
378cc40b 704 int oldsave = savestack->ary_fill;
35c8bce7
LW
705 int oldtmps_base = tmps_base;
706 register CSV *csv;
378cc40b 707 SUBR *sub;
8d063cd8 708
00bf170e
LW
709#ifdef OS2 /* or anybody else who requires SIG_ACK */
710 signal(sig, SIG_ACK);
711#endif
a687059c
LW
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 }
378cc40b
LW
725 if (!sub) {
726 if (dowarn)
727 warn("SIG%s handler \"%s\" not defined.\n",
a687059c 728 sig_name[sig], stab_name(stab) );
378cc40b
LW
729 return;
730 }
f0fcb552 731 /*SUPPRESS 701*/
35c8bce7
LW
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);
a687059c 746 stack->ary_flags = 0;
35c8bce7
LW
747 curcsv = csv;
748 str = str_mortal(&str_undef);
8d063cd8 749 str_set(str,sig_name[sig]);
a687059c 750 (void)apush(stab_xarray(defstab),str);
378cc40b
LW
751 sub->depth++;
752 if (sub->depth >= 2) { /* save temporaries on recursion? */
753 if (sub->depth == 100 && dowarn)
a687059c 754 warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
378cc40b
LW
755 savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
756 }
378cc40b 757
35c8bce7
LW
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 */
8d063cd8
LW
763}
764
8d063cd8
LW
765STAB *
766aadd(stab)
767register STAB *stab;
768{
a687059c
LW
769 if (!stab_xarray(stab))
770 stab_xarray(stab) = anew(stab);
8d063cd8
LW
771 return stab;
772}
773
774STAB *
775hadd(stab)
776register STAB *stab;
777{
a687059c
LW
778 if (!stab_xhash(stab))
779 stab_xhash(stab) = hnew(COEFFSIZE);
8d063cd8
LW
780 return stab;
781}
378cc40b
LW
782
783STAB *
0a12ae7d
LW
784fstab(name)
785char *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
798STAB *
378cc40b
LW
799stabent(name,add)
800register char *name;
801int add;
802{
803 register STAB *stab;
a687059c
LW
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;
378cc40b 811
f0fcb552 812 if (isUPPER(*name)) {
a687059c
LW
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;
378cc40b 820 }
a687059c
LW
821 else if (*name > 'E') {
822 if (*name == 'I' && strEQ(name, "INC"))
823 global = TRUE;
824 }
00bf170e 825 else if (*name > 'A') {
a687059c
LW
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 }
f0fcb552 843 else if (!isALPHA(*name) || global)
a687059c 844 stash = defstash;
f0fcb552 845 else if ((CMD*)curcmd == &compiling)
a687059c 846 stash = curstash;
0a12ae7d
LW
847 else
848 stash = curcmd->c_stash;
a687059c
LW
849 if (sawquote) {
850 char tmpbuf[256];
851 char *s, *d;
852
853 *sawquote = '\0';
f0fcb552 854 /*SUPPRESS 560*/
a687059c
LW
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);
0a12ae7d
LW
868 if (!stash->tbl_name)
869 stash->tbl_name = savestr(name);
a687059c
LW
870 name = sawquote+1;
871 *sawquote = '\'';
378cc40b 872 }
a687059c
LW
873 len = namend - name;
874 stab = (STAB*)hfetch(stash,name,len,add);
0a12ae7d 875 if (stab == (STAB*)&str_undef)
a687059c
LW
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;
9f68db38 888 strcpy(stab_magic(stab),"StB");
a687059c 889 stab_val(stab) = Str_new(72,0);
00bf170e 890 stab_line(stab) = curcmd->c_line;
f0fcb552 891 str_magic((STR*)stab, stab, '*', name, len);
0a12ae7d 892 stab_stash(stab) = stash;
f0fcb552 893 if (isDIGIT(*name) && *name != '0') {
fe14fcc3
LW
894 stab_flags(stab) = SF_VMAGIC;
895 str_magic(stab_val(stab), stab, 0, Nullch, 0);
896 }
f0fcb552
LW
897 if (add & 2)
898 stab->str_pok |= SP_MULTI;
378cc40b
LW
899 return stab;
900 }
378cc40b
LW
901}
902
0a12ae7d
LW
903stab_fullname(str,stab)
904STR *str;
905STAB *stab;
906{
fe14fcc3
LW
907 HASH *tb = stab_stash(stab);
908
909 if (!tb)
910 return;
911 str_set(str,tb->tbl_name);
0a12ae7d
LW
912 str_ncat(str,"'", 1);
913 str_scat(str,stab->str_magic);
914}
915
378cc40b
LW
916STIO *
917stio_new()
918{
a687059c 919 STIO *stio;
378cc40b 920
a687059c 921 Newz(603,stio,1,STIO);
378cc40b
LW
922 stio->page_len = 60;
923 return stio;
924}
925
926stab_check(min,max)
927int min;
928register int max;
929{
a687059c 930 register HENT *entry;
378cc40b
LW
931 register int i;
932 register STAB *stab;
933
934 for (i = min; i <= max; i++) {
a687059c
LW
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)
378cc40b 938 continue;
00bf170e 939 curcmd->c_line = stab_line(stab);
a687059c 940 warn("Possible typo: \"%s\"", stab_name(stab));
378cc40b
LW
941 }
942 }
943}
a687059c
LW
944
945static int gensym = 0;
946
947STAB *
948genstab()
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
956void
957stab_clear(stab)
958register STAB *stab;
959{
960 STIO *stio;
961 SUBR *sub;
962
963 afree(stab_xarray(stab));
fe14fcc3 964 stab_xarray(stab) = Null(ARRAY*);
0a12ae7d 965 (void)hfree(stab_xhash(stab), FALSE);
fe14fcc3 966 stab_xhash(stab) = Null(HASH*);
a687059c 967 str_free(stab_val(stab));
fe14fcc3 968 stab_val(stab) = Nullstr;
f0fcb552 969 /*SUPPRESS 560*/
a687059c
LW
970 if (stio = stab_io(stab)) {
971 do_close(stab,FALSE);
972 Safefree(stio->top_name);
973 Safefree(stio->fmt_name);
f0fcb552 974 Safefree(stio);
a687059c 975 }
f0fcb552 976 /*SUPPRESS 560*/
a687059c
LW
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
9f68db38
LW
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 */
992ARRAY *stab_array(stab)
993register 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
1001HASH *stab_hash(stab)
1002register 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 */