projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
perl 3.0 patch #22 patch #19, continued
[p5sagit/p5-mst-13.2.git] / perly.c
CommitLineData
0f85fab0 1char rcsid[] = "$Header: perly.c,v 3.0.1.5 90/03/27 16:20:57 lwall Locked $\nPatch level: ###\n";
8d063cd8 2/*
a687059c 3 * Copyright (c) 1989, Larry Wall
4 *
5 * You may distribute under the terms of the GNU General Public License
6 * as specified in the README file that comes with the perl 3.0 kit.
7 *
8d063cd8 8 * $Log: perly.c,v $
0f85fab0 9 * Revision 3.0.1.5 90/03/27 16:20:57 lwall
10 * patch16: MSDOS support
11 * patch16: do FILE inside eval blows up
12 *
ac58e20f 13 * Revision 3.0.1.4 90/02/28 18:06:41 lwall
14 * patch9: perl can now start up other interpreters scripts
15 * patch9: nested evals clobbered their longjmp environment
16 * patch9: eval could mistakenly return undef in array context
17 *
663a0e37 18 * Revision 3.0.1.3 89/12/21 20:15:41 lwall
19 * patch7: ANSI strerror() is now supported
20 * patch7: errno may now be a macro with an lvalue
21 * patch7: allowed setuid scripts to have a space after #!
22 *
ffed7fef 23 * Revision 3.0.1.2 89/11/17 15:34:42 lwall
24 * patch5: fixed possible confusion about current effective gid
25 *
ae986130 26 * Revision 3.0.1.1 89/11/11 04:50:04 lwall
27 * patch2: moved yydebug to where its type didn't matter
28 *
a687059c 29 * Revision 3.0 89/10/18 15:22:21 lwall
30 * 3.0 baseline
8d063cd8 31 *
32 */
33
378cc40b 34#include "EXTERN.h"
35#include "perl.h"
36#include "perly.h"
a687059c 37#include "patchlevel.h"
378cc40b 38
a687059c 39#ifdef IAMSUID
40#ifndef DOSUID
41#define DOSUID
42#endif
43#endif
378cc40b 44
a687059c 45#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
46#ifdef DOSUID
47#undef DOSUID
48#endif
49#endif
8d063cd8 50
51main(argc,argv,env)
52register int argc;
53register char **argv;
54register char **env;
55{
56 register STR *str;
57 register char *s;
378cc40b 58 char *index(), *strcpy(), *getenv();
59 bool dosearch = FALSE;
a687059c 60#ifdef DOSUID
13281fa4 61 char *validarg = "";
62#endif
8d063cd8 63
a687059c 64#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
65#ifdef IAMSUID
66#undef IAMSUID
67 fatal("suidperl is no longer needed since the kernel can now execute\n\
68setuid perl scripts securely.\n");
69#endif
70#endif
71
ac58e20f 72 origargv = argv;
73 origargc = argc;
378cc40b 74 uid = (int)getuid();
75 euid = (int)geteuid();
a687059c 76 gid = (int)getgid();
77 egid = (int)getegid();
0f85fab0 78#ifdef MSDOS
79 /*
80 * There is no way we can refer to them from Perl so close them to save
81 * space. The other alternative would be to provide STDAUX and STDPRN
82 * filehandles.
83 */
84 (void)fclose(stdaux);
85 (void)fclose(stdprn);
86#endif
a687059c 87 if (do_undump) {
88 do_undump = 0;
ac58e20f 89 loop_ptr = -1; /* start label stack again */
a687059c 90 goto just_doit;
91 }
92 (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
93 linestr = Str_new(65,80);
378cc40b 94 str_nset(linestr,"",0);
a687059c 95 str = str_make("",0); /* first used for -I flags */
96 curstash = defstash = hnew(0);
97 curstname = str_make("main",4);
98 stab_xhash(stabent("_main",TRUE)) = defstash;
378cc40b 99 incstab = aadd(stabent("INC",TRUE));
a687059c 100 incstab->str_pok |= SP_MULTI;
8d063cd8 101 for (argc--,argv++; argc; argc--,argv++) {
102 if (argv[0][0] != '-' || !argv[0][1])
103 break;
13281fa4 104#ifdef DOSUID
105 if (*validarg)
106 validarg = " PHOOEY ";
107 else
108 validarg = argv[0];
109#endif
110 s = argv[0]+1;
8d063cd8 111 reswitch:
13281fa4 112 switch (*s) {
378cc40b 113 case 'a':
114 minus_a = TRUE;
13281fa4 115 s++;
378cc40b 116 goto reswitch;
a687059c 117 case 'd':
118#ifdef TAINT
119 if (euid != uid || egid != gid)
120 fatal("No -d allowed in setuid scripts");
121#endif
122 perldb = TRUE;
123 s++;
124 goto reswitch;
8d063cd8 125 case 'D':
ae986130 126#ifdef DEBUGGING
a687059c 127#ifdef TAINT
128 if (euid != uid || egid != gid)
129 fatal("No -D allowed in setuid scripts");
130#endif
13281fa4 131 debug = atoi(s+1);
ae986130 132#else
133 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
8d063cd8 134#endif
135 break;
8d063cd8 136 case 'e':
a687059c 137#ifdef TAINT
138 if (euid != uid || egid != gid)
139 fatal("No -e allowed in setuid scripts");
140#endif
8d063cd8 141 if (!e_fp) {
a687059c 142 e_tmpname = savestr(TMPPATH);
143 (void)mktemp(e_tmpname);
8d063cd8 144 e_fp = fopen(e_tmpname,"w");
145 }
146 if (argv[1])
147 fputs(argv[1],e_fp);
a687059c 148 (void)putc('\n', e_fp);
8d063cd8 149 argc--,argv++;
150 break;
151 case 'i':
13281fa4 152 inplace = savestr(s+1);
8d063cd8 153 argvoutstab = stabent("ARGVOUT",TRUE);
154 break;
155 case 'I':
a687059c 156#ifdef TAINT
157 if (euid != uid || egid != gid)
158 fatal("No -I allowed in setuid scripts");
159#endif
13281fa4 160 str_cat(str,"-");
161 str_cat(str,s);
8d063cd8 162 str_cat(str," ");
a687059c 163 if (*++s) {
164 (void)apush(stab_array(incstab),str_make(s,0));
378cc40b 165 }
166 else {
a687059c 167 (void)apush(stab_array(incstab),str_make(argv[1],0));
8d063cd8 168 str_cat(str,argv[1]);
169 argc--,argv++;
170 str_cat(str," ");
171 }
172 break;
173 case 'n':
378cc40b 174 minus_n = TRUE;
13281fa4 175 s++;
8d063cd8 176 goto reswitch;
177 case 'p':
378cc40b 178 minus_p = TRUE;
13281fa4 179 s++;
8d063cd8 180 goto reswitch;
181 case 'P':
a687059c 182#ifdef TAINT
183 if (euid != uid || egid != gid)
184 fatal("No -P allowed in setuid scripts");
185#endif
8d063cd8 186 preprocess = TRUE;
13281fa4 187 s++;
8d063cd8 188 goto reswitch;
189 case 's':
a687059c 190#ifdef TAINT
191 if (euid != uid || egid != gid)
192 fatal("No -s allowed in setuid scripts");
193#endif
8d063cd8 194 doswitches = TRUE;
13281fa4 195 s++;
8d063cd8 196 goto reswitch;
378cc40b 197 case 'S':
198 dosearch = TRUE;
13281fa4 199 s++;
378cc40b 200 goto reswitch;
a687059c 201 case 'u':
202 do_undump = TRUE;
203 s++;
204 goto reswitch;
378cc40b 205 case 'U':
206 unsafe = TRUE;
13281fa4 207 s++;
378cc40b 208 goto reswitch;
8d063cd8 209 case 'v':
a687059c 210 fputs(rcsid,stdout);
0f85fab0 211 fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",stdout);
212#ifdef MSDOS
213 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
214 stdout);
215#endif
216 fputs("\n\
a687059c 217Perl may be copied only under the terms of the GNU General Public License,\n\
218a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
8d063cd8 219 exit(0);
378cc40b 220 case 'w':
221 dowarn = TRUE;
13281fa4 222 s++;
378cc40b 223 goto reswitch;
8d063cd8 224 case '-':
225 argc--,argv++;
226 goto switch_end;
227 case 0:
228 break;
229 default:
13281fa4 230 fatal("Unrecognized switch: -%s",s);
8d063cd8 231 }
232 }
233 switch_end:
234 if (e_fp) {
a687059c 235 (void)fclose(e_fp);
8d063cd8 236 argc++,argv--;
237 argv[0] = e_tmpname;
238 }
378cc40b 239#ifndef PRIVLIB
240#define PRIVLIB "/usr/local/lib/perl"
241#endif
a687059c 242 (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
8d063cd8 243
244 str_set(&str_no,No);
245 str_set(&str_yes,Yes);
8d063cd8 246
247 /* open script */
248
249 if (argv[0] == Nullch)
250 argv[0] = "-";
a687059c 251 if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
378cc40b 252 char *xfound = Nullch, *xfailed = Nullch;
a687059c 253 int len;
378cc40b 254
a687059c 255 bufend = s + strlen(s);
378cc40b 256 while (*s) {
a687059c 257 s = cpytill(tokenbuf,s,bufend,':',&len);
378cc40b 258 if (*s)
259 s++;
a687059c 260 if (len)
261 (void)strcat(tokenbuf+len,"/");
262 (void)strcat(tokenbuf+len,argv[0]);
378cc40b 263#ifdef DEBUGGING
264 if (debug & 1)
265 fprintf(stderr,"Looking for %s\n",tokenbuf);
266#endif
267 if (stat(tokenbuf,&statbuf) < 0) /* not there? */
268 continue;
269 if ((statbuf.st_mode & S_IFMT) == S_IFREG
a687059c 270 && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) {
378cc40b 271 xfound = tokenbuf; /* bingo! */
272 break;
273 }
274 if (!xfailed)
275 xfailed = savestr(tokenbuf);
276 }
277 if (!xfound)
a687059c 278 fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
378cc40b 279 if (xfailed)
a687059c 280 Safefree(xfailed);
378cc40b 281 argv[0] = savestr(xfound);
282 }
a687059c 283
284 pidstatary = anew(Nullstab); /* for remembering popen pids, status */
285
8d063cd8 286 filename = savestr(argv[0]);
378cc40b 287 origfilename = savestr(filename);
8d063cd8 288 if (strEQ(filename,"-"))
289 argv[0] = "";
290 if (preprocess) {
378cc40b 291 str_cat(str,"-I");
292 str_cat(str,PRIVLIB);
a687059c 293 (void)sprintf(buf, "\
8d063cd8 294/bin/sed -e '/^[^#]/b' \
295 -e '/^#[ ]*include[ ]/b' \
296 -e '/^#[ ]*define[ ]/b' \
297 -e '/^#[ ]*if[ ]/b' \
298 -e '/^#[ ]*ifdef[ ]/b' \
378cc40b 299 -e '/^#[ ]*ifndef[ ]/b' \
8d063cd8 300 -e '/^#[ ]*else/b' \
301 -e '/^#[ ]*endif/b' \
302 -e 's/^#.*//' \
378cc40b 303 %s | %s -C %s %s",
304 argv[0], CPPSTDIN, str_get(str), CPPMINUS);
a687059c 305#ifdef IAMSUID /* actually, this is caught earlier */
13281fa4 306 if (euid != uid && !euid) /* if running suidperl */
a687059c 307#ifdef SETEUID
308 (void)seteuid(uid); /* musn't stay setuid root */
309#else
310#ifdef SETREUID
311 (void)setreuid(-1, uid);
312#else
313 setuid(uid);
314#endif
13281fa4 315#endif
a687059c 316#endif /* IAMSUID */
317 rsfp = mypopen(buf,"r");
8d063cd8 318 }
319 else if (!*argv[0])
320 rsfp = stdin;
321 else
322 rsfp = fopen(argv[0],"r");
13281fa4 323 if (rsfp == Nullfp) {
324#ifdef DOSUID
a687059c 325#ifndef IAMSUID /* in case script is not readable before setuid */
13281fa4 326 if (euid && stat(filename,&statbuf) >= 0 &&
327 statbuf.st_mode & (S_ISUID|S_ISGID)) {
a687059c 328 (void)sprintf(buf, "%s/%s", BIN, "suidperl");
329 execv(buf, origargv); /* try again */
13281fa4 330 fatal("Can't do setuid\n");
331 }
332#endif
333#endif
a687059c 334 fatal("Can't open perl script \"%s\": %s\n",
663a0e37 335 filename, strerror(errno));
13281fa4 336 }
8d063cd8 337 str_free(str); /* free -I directories */
338
13281fa4 339 /* do we need to emulate setuid on scripts? */
340
341 /* This code is for those BSD systems that have setuid #! scripts disabled
342 * in the kernel because of a security problem. Merely defining DOSUID
343 * in perl will not fix that problem, but if you have disabled setuid
344 * scripts in the kernel, this will attempt to emulate setuid and setgid
345 * on scripts that have those now-otherwise-useless bits set. The setuid
346 * root version must be called suidperl. If regular perl discovers that
347 * it has opened a setuid script, it calls suidperl with the same argv
348 * that it had. If suidperl finds that the script it has just opened
349 * is NOT setuid root, it sets the effective uid back to the uid. We
350 * don't just make perl setuid root because that loses the effective
351 * uid we had before invoking perl, if it was different from the uid.
352 *
353 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
354 * be defined in suidperl only. suidperl must be setuid root. The
355 * Configure script will set this up for you if you want it.
a687059c 356 *
357 * There is also the possibility of have a script which is running
358 * set-id due to a C wrapper. We want to do the TAINT checks
359 * on these set-id scripts, but don't want to have the overhead of
360 * them in normal perl, and can't use suidperl because it will lose
361 * the effective uid info, so we have an additional non-setuid root
362 * version called taintperl that just does the TAINT checks.
13281fa4 363 */
a687059c 364
13281fa4 365#ifdef DOSUID
366 if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
367 fatal("Can't stat script \"%s\"",filename);
368 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
369 int len;
370
a687059c 371#ifdef IAMSUID
372#ifndef SETREUID
373 /* On this access check to make sure the directories are readable,
374 * there is actually a small window that the user could use to make
375 * filename point to an accessible directory. So there is a faint
376 * chance that someone could execute a setuid script down in a
377 * non-accessible directory. I don't know what to do about that.
378 * But I don't think it's too important. The manual lies when
379 * it says access() is useful in setuid programs.
380 */
13281fa4 381 if (access(filename,1)) /* as a double check */
382 fatal("Permission denied");
a687059c 383#else
384 /* If we can swap euid and uid, then we can determine access rights
385 * with a simple stat of the file, and then compare device and
386 * inode to make sure we did stat() on the same file we opened.
387 * Then we just have to make sure he or she can execute it.
388 */
389 {
390 struct stat tmpstatbuf;
391
392 if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
393 fatal("Can't swap uid and euid"); /* really paranoid */
394 if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
395 fatal("Permission denied");
396 if (tmpstatbuf.st_dev != statbuf.st_dev ||
397 tmpstatbuf.st_ino != statbuf.st_ino) {
398 (void)fclose(rsfp);
399 if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
400 fprintf(rsfp,
401"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
402(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
403 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
404 statbuf.st_dev, statbuf.st_ino,
405 filename, statbuf.st_uid, statbuf.st_gid);
406 (void)mypclose(rsfp);
407 }
408 fatal("Permission denied\n");
409 }
410 if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
411 fatal("Can't reswap uid and euid");
412 if (!cando(S_IEXEC,FALSE,&statbuf)) /* can real uid exec? */
413 fatal("Permission denied\n");
414 }
415#endif /* SETREUID */
416#endif /* IAMSUID */
417
13281fa4 418 if ((statbuf.st_mode & S_IFMT) != S_IFREG)
419 fatal("Permission denied");
a687059c 420 if ((statbuf.st_mode >> 6) & S_IWRITE)
421 fatal("Setuid/gid script is writable by world");
13281fa4 422 doswitches = FALSE; /* -s is insecure in suid */
423 line++;
424 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
425 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
426 fatal("No #! line");
663a0e37 427 s = tokenbuf+2;
428 if (*s == ' ') s++;
429 while (!isspace(*s)) s++;
13281fa4 430 if (strnNE(s-4,"perl",4)) /* sanity check */
431 fatal("Not a perl script");
a687059c 432 while (*s == ' ' || *s == '\t') s++;
13281fa4 433 /*
434 * #! arg must be what we saw above. They can invoke it by
435 * mentioning suidperl explicitly, but they may not add any strange
436 * arguments beyond what #! says if they do invoke suidperl that way.
437 */
438 len = strlen(validarg);
439 if (strEQ(validarg," PHOOEY ") ||
440 strnNE(s,validarg,len) || !isspace(s[len]))
a687059c 441 fatal("Args must match #! line");
442
443#ifndef IAMSUID
444 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
445 euid == statbuf.st_uid)
446 if (!do_undump)
447 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
448FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
449#endif /* IAMSUID */
13281fa4 450
451 if (euid) { /* oops, we're not the setuid root perl */
a687059c 452 (void)fclose(rsfp);
13281fa4 453#ifndef IAMSUID
a687059c 454 (void)sprintf(buf, "%s/%s", BIN, "suidperl");
455 execv(buf, origargv); /* try again */
13281fa4 456#endif
457 fatal("Can't do setuid\n");
458 }
459
ffed7fef 460 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
a687059c 461#ifdef SETEGID
462 (void)setegid(statbuf.st_gid);
463#else
464#ifdef SETREGID
465 (void)setregid((GIDTYPE)-1,statbuf.st_gid);
466#else
467 setgid(statbuf.st_gid);
468#endif
469#endif
470 if (statbuf.st_mode & S_ISUID) {
471 if (statbuf.st_uid != euid)
472#ifdef SETEUID
473 (void)seteuid(statbuf.st_uid); /* all that for this */
474#else
475#ifdef SETREUID
476 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
477#else
478 setuid(statbuf.st_uid);
479#endif
480#endif
481 }
482 else if (uid) /* oops, mustn't run as root */
483#ifdef SETEUID
484 (void)seteuid((UIDTYPE)uid);
485#else
486#ifdef SETREUID
487 (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
488#else
489 setuid((UIDTYPE)uid);
490#endif
491#endif
ffed7fef 492 uid = (int)getuid();
13281fa4 493 euid = (int)geteuid();
ffed7fef 494 gid = (int)getgid();
495 egid = (int)getegid();
a687059c 496 if (!cando(S_IEXEC,TRUE,&statbuf))
13281fa4 497 fatal("Permission denied\n"); /* they can't do this */
498 }
499#ifdef IAMSUID
500 else if (preprocess)
501 fatal("-P not allowed for setuid/setgid script\n");
502 else
503 fatal("Script is not setuid/setgid in suidperl\n");
a687059c 504#else
505#ifndef TAINT /* we aren't taintperl or suidperl */
506 /* script has a wrapper--can't run suidperl or we lose euid */
507 else if (euid != uid || egid != gid) {
508 (void)fclose(rsfp);
509 (void)sprintf(buf, "%s/%s", BIN, "taintperl");
510 execv(buf, origargv); /* try again */
511 fatal("Can't run setuid script with taint checks");
512 }
513#endif /* TAINT */
13281fa4 514#endif /* IAMSUID */
a687059c 515#else /* !DOSUID */
516#ifndef TAINT /* we aren't taintperl or suidperl */
517 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
518#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
519 fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
520 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
521 ||
522 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
523 )
524 if (!do_undump)
525 fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
526FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
527#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
528 /* not set-id, must be wrapped */
529 (void)fclose(rsfp);
530 (void)sprintf(buf, "%s/%s", BIN, "taintperl");
531 execv(buf, origargv); /* try again */
532 fatal("Can't run setuid script with taint checks");
533 }
534#endif /* TAINT */
13281fa4 535#endif /* DOSUID */
536
8d063cd8 537 defstab = stabent("_",TRUE);
538
a687059c 539 if (perldb) {
540 debstash = hnew(0);
541 stab_xhash(stabent("_DB",TRUE)) = debstash;
542 curstash = debstash;
543 lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
544 tmpstab->str_pok |= SP_MULTI;
545 subname = str_make("main",4);
546 DBstab = stabent("DB",TRUE);
547 DBstab->str_pok |= SP_MULTI;
548 DBsub = hadd(tmpstab = stabent("sub",TRUE));
549 tmpstab->str_pok |= SP_MULTI;
550 DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
551 tmpstab->str_pok |= SP_MULTI;
552 curstash = defstash;
553 }
554
8d063cd8 555 /* init tokener */
556
a687059c 557 bufend = bufptr = str_get(linestr);
558
559 savestack = anew(Nullstab); /* for saving non-local values */
560 stack = anew(Nullstab); /* for saving non-local values */
561 stack->ary_flags = 0; /* not a real array */
8d063cd8 562
a687059c 563 /* now parse the script */
8d063cd8 564
a687059c 565 error_count = 0;
566 if (yyparse() || error_count)
8d063cd8 567 fatal("Execution aborted due to compilation errors.\n");
568
a687059c 569 New(50,loop_stack,128,struct loop);
ae986130 570#ifdef DEBUGGING
571 if (debug) {
572 New(51,debname,128,char);
573 New(52,debdelim,128,char);
574 }
575#endif
a687059c 576 curstash = defstash;
378cc40b 577
578 preprocess = FALSE;
8d063cd8 579 if (e_fp) {
580 e_fp = Nullfp;
a687059c 581 (void)UNLINK(e_tmpname);
582 }
583
584 /* initialize everything that won't change if we undump */
585
586 if (sigstab = stabent("SIG",allstabs)) {
587 sigstab->str_pok |= SP_MULTI;
588 (void)hadd(sigstab);
589 }
590
591 magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
592
593 amperstab = stabent("&",allstabs);
594 leftstab = stabent("`",allstabs);
595 rightstab = stabent("'",allstabs);
596 sawampersand = (amperstab || leftstab || rightstab);
597 if (tmpstab = stabent(":",allstabs))
598 str_set(STAB_STR(tmpstab),chopset);
599
600 /* these aren't necessarily magical */
601 if (tmpstab = stabent(";",allstabs))
602 str_set(STAB_STR(tmpstab),"\034");
603#ifdef TAINT
604 tainted = 1;
605#endif
606 if (tmpstab = stabent("0",allstabs))
607 str_set(STAB_STR(tmpstab),origfilename);
608#ifdef TAINT
609 tainted = 0;
610#endif
611 if (tmpstab = stabent("]",allstabs))
612 str_set(STAB_STR(tmpstab),rcsid);
613 str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
614
615 stdinstab = stabent("STDIN",TRUE);
616 stdinstab->str_pok |= SP_MULTI;
617 stab_io(stdinstab) = stio_new();
618 stab_io(stdinstab)->ifp = stdin;
619 tmpstab = stabent("stdin",TRUE);
620 stab_io(tmpstab) = stab_io(stdinstab);
621 tmpstab->str_pok |= SP_MULTI;
622
623 tmpstab = stabent("STDOUT",TRUE);
624 tmpstab->str_pok |= SP_MULTI;
625 stab_io(tmpstab) = stio_new();
626 stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
627 defoutstab = tmpstab;
628 tmpstab = stabent("stdout",TRUE);
629 stab_io(tmpstab) = stab_io(defoutstab);
630 tmpstab->str_pok |= SP_MULTI;
631
632 curoutstab = stabent("STDERR",TRUE);
633 curoutstab->str_pok |= SP_MULTI;
634 stab_io(curoutstab) = stio_new();
635 stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
636 tmpstab = stabent("stderr",TRUE);
637 stab_io(tmpstab) = stab_io(curoutstab);
638 tmpstab->str_pok |= SP_MULTI;
639 curoutstab = defoutstab; /* switch back to STDOUT */
640
641 statname = Str_new(66,0); /* last filename we did stat on */
642
643 perldb = FALSE; /* don't try to instrument evals */
644
645 if (dowarn) {
646 stab_check('A','Z');
647 stab_check('a','z');
8d063cd8 648 }
a687059c 649
650 if (do_undump)
651 abort();
652
653 just_doit: /* come here if running an undumped a.out */
8d063cd8 654 argc--,argv++; /* skip name of script */
655 if (doswitches) {
656 for (; argc > 0 && **argv == '-'; argc--,argv++) {
657 if (argv[0][1] == '-') {
658 argc--,argv++;
659 break;
660 }
a687059c 661 str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
8d063cd8 662 }
663 }
a687059c 664#ifdef TAINT
665 tainted = 1;
666#endif
a559c259 667 if (argvstab = stabent("ARGV",allstabs)) {
a687059c 668 argvstab->str_pok |= SP_MULTI;
669 (void)aadd(argvstab);
8d063cd8 670 for (; argc > 0; argc--,argv++) {
a687059c 671 (void)apush(stab_array(argvstab),str_make(argv[0],0));
8d063cd8 672 }
673 }
a687059c 674#ifdef TAINT
675 (void) stabent("ENV",TRUE); /* must test PATH and IFS */
676#endif
a559c259 677 if (envstab = stabent("ENV",allstabs)) {
a687059c 678 envstab->str_pok |= SP_MULTI;
679 (void)hadd(envstab);
8d063cd8 680 for (; *env; env++) {
681 if (!(s = index(*env,'=')))
682 continue;
683 *s++ = '\0';
a687059c 684 str = str_make(s--,0);
685 str_magic(str, envstab, 'E', *env, s - *env);
686 (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
687 *s = '=';
8d063cd8 688 }
689 }
a687059c 690#ifdef TAINT
691 tainted = 0;
692#endif
378cc40b 693 if (tmpstab = stabent("$",allstabs))
8d063cd8 694 str_numset(STAB_STR(tmpstab),(double)getpid());
695
a687059c 696 if (setjmp(top_env)) /* sets goto_targ on longjump */
ac58e20f 697 loop_ptr = -1; /* start label stack again */
8d063cd8 698
699#ifdef DEBUGGING
700 if (debug & 1024)
a687059c 701 dump_all();
8d063cd8 702 if (debug)
703 fprintf(stderr,"\nEXECUTING...\n\n");
704#endif
705
706 /* do it */
707
a687059c 708 (void) cmd_exec(main_root,G_SCALAR,-1);
8d063cd8 709
710 if (goto_targ)
378cc40b 711 fatal("Can't find label \"%s\"--aborting",goto_targ);
8d063cd8 712 exit(0);
378cc40b 713 /* NOTREACHED */
8d063cd8 714}
715
716magicalize(list)
717register char *list;
718{
719 register STAB *stab;
720 char sym[2];
721
722 sym[1] = '\0';
723 while (*sym = *list++) {
a559c259 724 if (stab = stabent(sym,allstabs)) {
a687059c 725 stab_flags(stab) = SF_VMAGIC;
726 str_magic(stab_val(stab), stab, 0, Nullch, 0);
378cc40b 727 }
378cc40b 728 }
8d063cd8 729}
730
a687059c 731/* this routine is in perly.c by virtue of being sort of an alternate main() */
8d063cd8 732
a687059c 733int
734do_eval(str,optype,stash,gimme,arglast)
735STR *str;
736int optype;
737HASH *stash;
738int gimme;
739int *arglast;
8d063cd8 740{
a687059c 741 STR **st = stack->ary_array;
742 int retval;
743 CMD *myroot;
744 ARRAY *ar;
745 int i;
ac58e20f 746 char * VOLATILE oldfile = filename;
747 VOLATILE line_t oldline = line;
748 VOLATILE int oldtmps_base = tmps_base;
749 VOLATILE int oldsave = savestack->ary_fill;
750 SPAT * VOLATILE oldspat = curspat;
a687059c 751 static char *last_eval = Nullch;
752 static CMD *last_root = Nullcmd;
663a0e37 753 VOLATILE int sp = arglast[0];
ac58e20f 754 char *tmps;
8d063cd8 755
a687059c 756 tmps_base = tmps_max;
757 if (curstash != stash) {
758 (void)savehptr(&curstash);
759 curstash = stash;
8d063cd8 760 }
a687059c 761 str_set(stab_val(stabent("@",TRUE)),"");
762 if (optype != O_DOFILE) { /* normal eval */
763 filename = "(eval)";
764 line = 1;
765 str_sset(linestr,str);
766 str_cat(linestr,";"); /* be kind to them */
8d063cd8 767 }
a687059c 768 else {
0f85fab0 769 if (last_root && !in_eval) {
a687059c 770 Safefree(last_eval);
771 cmd_free(last_root);
772 last_root = Nullcmd;
8d063cd8 773 }
a687059c 774 filename = savestr(str_get(str)); /* can't free this easily */
775 str_set(linestr,"");
776 rsfp = fopen(filename,"r");
777 ar = stab_array(incstab);
778 if (!rsfp && *filename != '/') {
779 for (i = 0; i <= ar->ary_fill; i++) {
780 (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
781 rsfp = fopen(buf,"r");
782 if (rsfp) {
783 filename = savestr(buf);
8d063cd8 784 break;
785 }
378cc40b 786 }
787 }
a687059c 788 if (!rsfp) {
789 filename = oldfile;
790 tmps_base = oldtmps_base;
791 if (gimme != G_ARRAY)
792 st[++sp] = &str_undef;
793 return sp;
8d063cd8 794 }
a687059c 795 line = 0;
8d063cd8 796 }
a687059c 797 in_eval++;
798 oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
799 bufend = bufptr + linestr->str_cur;
ac58e20f 800 if (++loop_ptr >= loop_max) {
801 loop_max += 128;
802 Renew(loop_stack, loop_max, struct loop);
803 }
804 loop_stack[loop_ptr].loop_label = "_EVAL_";
805 loop_stack[loop_ptr].loop_sp = sp;
806#ifdef DEBUGGING
807 if (debug & 4) {
808 deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
809 }
810#endif
811 if (setjmp(loop_stack[loop_ptr].loop_env)) {
a687059c 812 retval = 1;
813 last_root = Nullcmd;
8d063cd8 814 }
a687059c 815 else {
816 error_count = 0;
817 if (rsfp)
818 retval = yyparse();
819 else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
820 retval = 0;
821 eval_root = last_root; /* no point in reparsing */
822 }
823 else if (in_eval == 1) {
824 if (last_root) {
825 Safefree(last_eval);
826 cmd_free(last_root);
8d063cd8 827 }
a687059c 828 last_eval = savestr(bufptr);
829 last_root = Nullcmd;
830 retval = yyparse();
831 if (!retval)
832 last_root = eval_root;
8d063cd8 833 }
a687059c 834 else
835 retval = yyparse();
8d063cd8 836 }
a687059c 837 myroot = eval_root; /* in case cmd_exec does another eval! */
838 if (retval || error_count) {
ac58e20f 839 st = stack->ary_array;
840 sp = arglast[0];
841 if (gimme != G_ARRAY)
842 st[++sp] = &str_undef;
a687059c 843 last_root = Nullcmd; /* can't free on error, for some reason */
844 if (rsfp) {
845 fclose(rsfp);
846 rsfp = 0;
847 }
8d063cd8 848 }
8d063cd8 849 else {
a687059c 850 sp = cmd_exec(eval_root,gimme,sp);
851 st = stack->ary_array;
852 for (i = arglast[0] + 1; i <= sp; i++)
853 st[i] = str_static(st[i]);
854 /* if we don't save result, free zaps it */
855 if (in_eval != 1 && myroot != last_root)
856 cmd_free(myroot);
a559c259 857 }
858 in_eval--;
ac58e20f 859#ifdef DEBUGGING
860 if (debug & 4) {
861 tmps = loop_stack[loop_ptr].loop_label;
862 deb("(Popping label #%d %s)\n",loop_ptr,
863 tmps ? tmps : "" );
864 }
865#endif
866 loop_ptr--;
378cc40b 867 filename = oldfile;
868 line = oldline;
869 tmps_base = oldtmps_base;
a687059c 870 curspat = oldspat;
378cc40b 871 if (savestack->ary_fill > oldsave) /* let them use local() */
872 restorelist(oldsave);
a687059c 873 return sp;
378cc40b 874}
Unnamed repository; edit this file to name it for gitweb.