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